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 !        print *,i,iti
2852         b1(1,i-2)=b(3,iti)
2853         b1(2,i-2)=b(5,iti)
2854         b2(1,i-2)=b(2,iti)
2855         b2(2,i-2)=b(4,iti)
2856         do k=1,2
2857           do l=1,2
2858            CC(k,l,i-2)=ccold(k,l,iti)
2859            DD(k,l,i-2)=ddold(k,l,iti)
2860            EE(k,l,i-2)=eeold(k,l,iti)
2861           enddo
2862         enddo
2863 #endif
2864         b1tilde(1,i-2)= b1(1,i-2)
2865         b1tilde(2,i-2)=-b1(2,i-2)
2866         b2tilde(1,i-2)= b2(1,i-2)
2867         b2tilde(2,i-2)=-b2(2,i-2)
2868 !c
2869         Ctilde(1,1,i-2)= CC(1,1,i-2)
2870         Ctilde(1,2,i-2)= CC(1,2,i-2)
2871         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2872         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2873 !c
2874         Dtilde(1,1,i-2)= DD(1,1,i-2)
2875         Dtilde(1,2,i-2)= DD(1,2,i-2)
2876         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2877         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2878       enddo
2879 #ifdef PARMAT
2880       do i=ivec_start+2,ivec_end+2
2881 #else
2882       do i=3,nres+1
2883 #endif
2884
2885 !      print *,i,"i"
2886         if (i .lt. nres+1) then
2887           sin1=dsin(phi(i))
2888           cos1=dcos(phi(i))
2889           sintab(i-2)=sin1
2890           costab(i-2)=cos1
2891           obrot(1,i-2)=cos1
2892           obrot(2,i-2)=sin1
2893           sin2=dsin(2*phi(i))
2894           cos2=dcos(2*phi(i))
2895           sintab2(i-2)=sin2
2896           costab2(i-2)=cos2
2897           obrot2(1,i-2)=cos2
2898           obrot2(2,i-2)=sin2
2899           Ug(1,1,i-2)=-cos1
2900           Ug(1,2,i-2)=-sin1
2901           Ug(2,1,i-2)=-sin1
2902           Ug(2,2,i-2)= cos1
2903           Ug2(1,1,i-2)=-cos2
2904           Ug2(1,2,i-2)=-sin2
2905           Ug2(2,1,i-2)=-sin2
2906           Ug2(2,2,i-2)= cos2
2907         else
2908           costab(i-2)=1.0d0
2909           sintab(i-2)=0.0d0
2910           obrot(1,i-2)=1.0d0
2911           obrot(2,i-2)=0.0d0
2912           obrot2(1,i-2)=0.0d0
2913           obrot2(2,i-2)=0.0d0
2914           Ug(1,1,i-2)=1.0d0
2915           Ug(1,2,i-2)=0.0d0
2916           Ug(2,1,i-2)=0.0d0
2917           Ug(2,2,i-2)=1.0d0
2918           Ug2(1,1,i-2)=0.0d0
2919           Ug2(1,2,i-2)=0.0d0
2920           Ug2(2,1,i-2)=0.0d0
2921           Ug2(2,2,i-2)=0.0d0
2922         endif
2923         if (i .gt. 3 .and. i .lt. nres+1) then
2924           obrot_der(1,i-2)=-sin1
2925           obrot_der(2,i-2)= cos1
2926           Ugder(1,1,i-2)= sin1
2927           Ugder(1,2,i-2)=-cos1
2928           Ugder(2,1,i-2)=-cos1
2929           Ugder(2,2,i-2)=-sin1
2930           dwacos2=cos2+cos2
2931           dwasin2=sin2+sin2
2932           obrot2_der(1,i-2)=-dwasin2
2933           obrot2_der(2,i-2)= dwacos2
2934           Ug2der(1,1,i-2)= dwasin2
2935           Ug2der(1,2,i-2)=-dwacos2
2936           Ug2der(2,1,i-2)=-dwacos2
2937           Ug2der(2,2,i-2)=-dwasin2
2938         else
2939           obrot_der(1,i-2)=0.0d0
2940           obrot_der(2,i-2)=0.0d0
2941           Ugder(1,1,i-2)=0.0d0
2942           Ugder(1,2,i-2)=0.0d0
2943           Ugder(2,1,i-2)=0.0d0
2944           Ugder(2,2,i-2)=0.0d0
2945           obrot2_der(1,i-2)=0.0d0
2946           obrot2_der(2,i-2)=0.0d0
2947           Ug2der(1,1,i-2)=0.0d0
2948           Ug2der(1,2,i-2)=0.0d0
2949           Ug2der(2,1,i-2)=0.0d0
2950           Ug2der(2,2,i-2)=0.0d0
2951         endif
2952 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2953         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2954            if (itype(i-2,1).eq.0) then
2955           iti=ntortyp+1
2956            else
2957           iti = itype2loc(itype(i-2,1))
2958            endif
2959         else
2960           iti=nloctyp
2961         endif
2962 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2963         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2964            if (itype(i-1,1).eq.0) then
2965           iti1=nloctyp
2966            else
2967           iti1 = itype2loc(itype(i-1,1))
2968            endif
2969         else
2970           iti1=nloctyp
2971         endif
2972 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2973 !d        write (iout,*) '*******i',i,' iti1',iti
2974 !        write (iout,*) 'b1',b1(:,iti)
2975 !        write (iout,*) 'b2',b2(:,i-2)
2976 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2977 !        if (i .gt. iatel_s+2) then
2978         if (i .gt. nnt+2) then
2979           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2980 #ifdef NEWCORR
2981           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2982 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2983 #endif
2984
2985           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2986           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2987           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2988           then
2989           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2990           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2991           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2992           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2993           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2994           endif
2995         else
2996           do k=1,2
2997             Ub2(k,i-2)=0.0d0
2998             Ctobr(k,i-2)=0.0d0
2999             Dtobr2(k,i-2)=0.0d0
3000             do l=1,2
3001               EUg(l,k,i-2)=0.0d0
3002               CUg(l,k,i-2)=0.0d0
3003               DUg(l,k,i-2)=0.0d0
3004               DtUg2(l,k,i-2)=0.0d0
3005             enddo
3006           enddo
3007         endif
3008         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3009         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3010         do k=1,2
3011           muder(k,i-2)=Ub2der(k,i-2)
3012         enddo
3013 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3014         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3015           if (itype(i-1,1).eq.0) then
3016            iti1=ntortyp+1
3017           elseif (itype(i-1,1).le.ntyp) then
3018             iti1 = itype2loc(itype(i-1,1))
3019           else
3020             iti1=nloctyp
3021           endif
3022         else
3023           iti1=nloctyp
3024         endif
3025         do k=1,2
3026           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3027         enddo
3028         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3029         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3030         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3031 !d        write (iout,*) 'mu1',mu1(:,i-2)
3032 !d        write (iout,*) 'mu2',mu2(:,i-2)
3033         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3034         then
3035         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3036         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3037         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3038         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3039         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3040 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3041         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3042         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3043         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3044         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3045         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3046         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3047         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3048         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3049         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3050         endif
3051       enddo
3052 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3053 ! The order of matrices is from left to right.
3054       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3055       then
3056 !      do i=max0(ivec_start,2),ivec_end
3057       do i=2,nres-1
3058         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3059         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3060         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3061         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3062         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3063         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3064         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3065         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3066       enddo
3067       endif
3068 #if defined(MPI) && defined(PARMAT)
3069 #ifdef DEBUG
3070 !      if (fg_rank.eq.0) then
3071         write (iout,*) "Arrays UG and UGDER before GATHER"
3072         do i=1,nres-1
3073           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3074            ((ug(l,k,i),l=1,2),k=1,2),&
3075            ((ugder(l,k,i),l=1,2),k=1,2)
3076         enddo
3077         write (iout,*) "Arrays UG2 and UG2DER"
3078         do i=1,nres-1
3079           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3080            ((ug2(l,k,i),l=1,2),k=1,2),&
3081            ((ug2der(l,k,i),l=1,2),k=1,2)
3082         enddo
3083         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3084         do i=1,nres-1
3085           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3086            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3087            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3088         enddo
3089         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3090         do i=1,nres-1
3091           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3092            costab(i),sintab(i),costab2(i),sintab2(i)
3093         enddo
3094         write (iout,*) "Array MUDER"
3095         do i=1,nres-1
3096           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3097         enddo
3098 !      endif
3099 #endif
3100       if (nfgtasks.gt.1) then
3101         time00=MPI_Wtime()
3102 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3103 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3104 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3105 #ifdef MATGATHER
3106         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3107          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3108          FG_COMM1,IERR)
3109         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3110          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3111          FG_COMM1,IERR)
3112         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3113          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3114          FG_COMM1,IERR)
3115         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3116          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3117          FG_COMM1,IERR)
3118         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3119          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3120          FG_COMM1,IERR)
3121         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3122          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3123          FG_COMM1,IERR)
3124         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3125          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3126          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3127         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3128          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3129          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3130         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3131          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3132          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3133         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3134          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3135          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3136         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3137         then
3138         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3139          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3140          FG_COMM1,IERR)
3141         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3142          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3143          FG_COMM1,IERR)
3144         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3145          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3146          FG_COMM1,IERR)
3147        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3148          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3149          FG_COMM1,IERR)
3150         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3151          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3152          FG_COMM1,IERR)
3153         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3154          ivec_count(fg_rank1),&
3155          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3156          FG_COMM1,IERR)
3157         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3158          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3159          FG_COMM1,IERR)
3160         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3161          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3162          FG_COMM1,IERR)
3163         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3164          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3165          FG_COMM1,IERR)
3166         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3167          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3168          FG_COMM1,IERR)
3169         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3170          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3171          FG_COMM1,IERR)
3172         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3173          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3174          FG_COMM1,IERR)
3175         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3176          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3177          FG_COMM1,IERR)
3178         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3179          ivec_count(fg_rank1),&
3180          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3181          FG_COMM1,IERR)
3182         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3183          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3184          FG_COMM1,IERR)
3185        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3186          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3187          FG_COMM1,IERR)
3188         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3189          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3190          FG_COMM1,IERR)
3191        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3192          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3193          FG_COMM1,IERR)
3194         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3195          ivec_count(fg_rank1),&
3196          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3197          FG_COMM1,IERR)
3198         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3199          ivec_count(fg_rank1),&
3200          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3201          FG_COMM1,IERR)
3202         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3203          ivec_count(fg_rank1),&
3204          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3205          MPI_MAT2,FG_COMM1,IERR)
3206         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3207          ivec_count(fg_rank1),&
3208          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3209          MPI_MAT2,FG_COMM1,IERR)
3210         endif
3211 #else
3212 ! Passes matrix info through the ring
3213       isend=fg_rank1
3214       irecv=fg_rank1-1
3215       if (irecv.lt.0) irecv=nfgtasks1-1
3216       iprev=irecv
3217       inext=fg_rank1+1
3218       if (inext.ge.nfgtasks1) inext=0
3219       do i=1,nfgtasks1-1
3220 !        write (iout,*) "isend",isend," irecv",irecv
3221 !        call flush(iout)
3222         lensend=lentyp(isend)
3223         lenrecv=lentyp(irecv)
3224 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3225 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3226 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3227 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3228 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3229 !        write (iout,*) "Gather ROTAT1"
3230 !        call flush(iout)
3231 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3232 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3233 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3234 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3235 !        write (iout,*) "Gather ROTAT2"
3236 !        call flush(iout)
3237         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3238          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3239          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3240          iprev,4400+irecv,FG_COMM,status,IERR)
3241 !        write (iout,*) "Gather ROTAT_OLD"
3242 !        call flush(iout)
3243         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3244          MPI_PRECOMP11(lensend),inext,5500+isend,&
3245          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3246          iprev,5500+irecv,FG_COMM,status,IERR)
3247 !        write (iout,*) "Gather PRECOMP11"
3248 !        call flush(iout)
3249         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3250          MPI_PRECOMP12(lensend),inext,6600+isend,&
3251          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3252          iprev,6600+irecv,FG_COMM,status,IERR)
3253 !        write (iout,*) "Gather PRECOMP12"
3254 !        call flush(iout)
3255         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3256         then
3257         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3258          MPI_ROTAT2(lensend),inext,7700+isend,&
3259          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3260          iprev,7700+irecv,FG_COMM,status,IERR)
3261 !        write (iout,*) "Gather PRECOMP21"
3262 !        call flush(iout)
3263         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3264          MPI_PRECOMP22(lensend),inext,8800+isend,&
3265          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3266          iprev,8800+irecv,FG_COMM,status,IERR)
3267 !        write (iout,*) "Gather PRECOMP22"
3268 !        call flush(iout)
3269         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3270          MPI_PRECOMP23(lensend),inext,9900+isend,&
3271          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3272          MPI_PRECOMP23(lenrecv),&
3273          iprev,9900+irecv,FG_COMM,status,IERR)
3274 !        write (iout,*) "Gather PRECOMP23"
3275 !        call flush(iout)
3276         endif
3277         isend=irecv
3278         irecv=irecv-1
3279         if (irecv.lt.0) irecv=nfgtasks1-1
3280       enddo
3281 #endif
3282         time_gather=time_gather+MPI_Wtime()-time00
3283       endif
3284 #ifdef DEBUG
3285 !      if (fg_rank.eq.0) then
3286         write (iout,*) "Arrays UG and UGDER"
3287         do i=1,nres-1
3288           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3289            ((ug(l,k,i),l=1,2),k=1,2),&
3290            ((ugder(l,k,i),l=1,2),k=1,2)
3291         enddo
3292         write (iout,*) "Arrays UG2 and UG2DER"
3293         do i=1,nres-1
3294           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3295            ((ug2(l,k,i),l=1,2),k=1,2),&
3296            ((ug2der(l,k,i),l=1,2),k=1,2)
3297         enddo
3298         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3299         do i=1,nres-1
3300           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3301            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3302            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3303         enddo
3304         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3305         do i=1,nres-1
3306           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3307            costab(i),sintab(i),costab2(i),sintab2(i)
3308         enddo
3309         write (iout,*) "Array MUDER"
3310         do i=1,nres-1
3311           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3312         enddo
3313 !      endif
3314 #endif
3315 #endif
3316 !d      do i=1,nres
3317 !d        iti = itortyp(itype(i,1))
3318 !d        write (iout,*) i
3319 !d        do j=1,2
3320 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3321 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3322 !d        enddo
3323 !d      enddo
3324       return
3325       end subroutine set_matrices
3326 !-----------------------------------------------------------------------------
3327       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3328 !
3329 ! This subroutine calculates the average interaction energy and its gradient
3330 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3331 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3332 ! The potential depends both on the distance of peptide-group centers and on
3333 ! the orientation of the CA-CA virtual bonds.
3334 !
3335       use comm_locel
3336 !      implicit real*8 (a-h,o-z)
3337 #ifdef MPI
3338       include 'mpif.h'
3339 #endif
3340 !      include 'DIMENSIONS'
3341 !      include 'COMMON.CONTROL'
3342 !      include 'COMMON.SETUP'
3343 !      include 'COMMON.IOUNITS'
3344 !      include 'COMMON.GEO'
3345 !      include 'COMMON.VAR'
3346 !      include 'COMMON.LOCAL'
3347 !      include 'COMMON.CHAIN'
3348 !      include 'COMMON.DERIV'
3349 !      include 'COMMON.INTERACT'
3350 !      include 'COMMON.CONTACTS'
3351 !      include 'COMMON.TORSION'
3352 !      include 'COMMON.VECTORS'
3353 !      include 'COMMON.FFIELD'
3354 !      include 'COMMON.TIME1'
3355       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3356       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3357       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3358 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3359       real(kind=8),dimension(4) :: muij
3360 !el      integer :: num_conti,j1,j2
3361 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3362 !el        dz_normi,xmedi,ymedi,zmedi
3363
3364 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3365 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3366 !el          num_conti,j1,j2
3367
3368 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3369 #ifdef MOMENT
3370       real(kind=8) :: scal_el=1.0d0
3371 #else
3372       real(kind=8) :: scal_el=0.5d0
3373 #endif
3374 ! 12/13/98
3375 ! 13-go grudnia roku pamietnego...
3376       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3377                                              0.0d0,1.0d0,0.0d0,&
3378                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3379 !el local variables
3380       integer :: i,k,j
3381       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3382       real(kind=8) :: fac,t_eelecij,fracinbuf
3383
3384
3385 !d      write(iout,*) 'In EELEC'
3386 !        print *,"IN EELEC"
3387 !d      do i=1,nloctyp
3388 !d        write(iout,*) 'Type',i
3389 !d        write(iout,*) 'B1',B1(:,i)
3390 !d        write(iout,*) 'B2',B2(:,i)
3391 !d        write(iout,*) 'CC',CC(:,:,i)
3392 !d        write(iout,*) 'DD',DD(:,:,i)
3393 !d        write(iout,*) 'EE',EE(:,:,i)
3394 !d      enddo
3395 !d      call check_vecgrad
3396 !d      stop
3397 !      ees=0.0d0  !AS
3398 !      evdw1=0.0d0
3399 !      eel_loc=0.0d0
3400 !      eello_turn3=0.0d0
3401 !      eello_turn4=0.0d0
3402       t_eelecij=0.0d0
3403       ees=0.0D0
3404       evdw1=0.0D0
3405       eel_loc=0.0d0
3406       eello_turn3=0.0d0
3407       eello_turn4=0.0d0
3408 !
3409
3410       if (icheckgrad.eq.1) then
3411 !el
3412 !        do i=0,2*nres+2
3413 !          dc_norm(1,i)=0.0d0
3414 !          dc_norm(2,i)=0.0d0
3415 !          dc_norm(3,i)=0.0d0
3416 !        enddo
3417         do i=1,nres-1
3418           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3419           do k=1,3
3420             dc_norm(k,i)=dc(k,i)*fac
3421           enddo
3422 !          write (iout,*) 'i',i,' fac',fac
3423         enddo
3424       endif
3425 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3426 !        wturn6
3427       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3428           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3429           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3430 !        call vec_and_deriv
3431 #ifdef TIMING
3432         time01=MPI_Wtime()
3433 #endif
3434 !        print *, "before set matrices"
3435         call set_matrices
3436 !        print *, "after set matrices"
3437
3438 #ifdef TIMING
3439         time_mat=time_mat+MPI_Wtime()-time01
3440 #endif
3441       endif
3442 !       print *, "after set matrices"
3443 !d      do i=1,nres-1
3444 !d        write (iout,*) 'i=',i
3445 !d        do k=1,3
3446 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3447 !d        enddo
3448 !d        do k=1,3
3449 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3450 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3451 !d        enddo
3452 !d      enddo
3453       t_eelecij=0.0d0
3454       ees=0.0D0
3455       evdw1=0.0D0
3456       eel_loc=0.0d0
3457       eello_turn3=0.0d0
3458       eello_turn4=0.0d0
3459 !el      ind=0
3460       do i=1,nres
3461         num_cont_hb(i)=0
3462       enddo
3463 !d      print '(a)','Enter EELEC'
3464 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3465 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3466 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3467       do i=1,nres
3468         gel_loc_loc(i)=0.0d0
3469         gcorr_loc(i)=0.0d0
3470       enddo
3471 !
3472 !
3473 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3474 !
3475 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3476 !
3477
3478
3479 !        print *,"before iturn3 loop"
3480       do i=iturn3_start,iturn3_end
3481         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3482         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3483         dxi=dc(1,i)
3484         dyi=dc(2,i)
3485         dzi=dc(3,i)
3486         dx_normi=dc_norm(1,i)
3487         dy_normi=dc_norm(2,i)
3488         dz_normi=dc_norm(3,i)
3489         xmedi=c(1,i)+0.5d0*dxi
3490         ymedi=c(2,i)+0.5d0*dyi
3491         zmedi=c(3,i)+0.5d0*dzi
3492           xmedi=dmod(xmedi,boxxsize)
3493           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3494           ymedi=dmod(ymedi,boxysize)
3495           if (ymedi.lt.0) ymedi=ymedi+boxysize
3496           zmedi=dmod(zmedi,boxzsize)
3497           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3498         num_conti=0
3499        if ((zmedi.gt.bordlipbot) &
3500         .and.(zmedi.lt.bordliptop)) then
3501 !C the energy transfer exist
3502         if (zmedi.lt.buflipbot) then
3503 !C what fraction I am in
3504          fracinbuf=1.0d0- &
3505                ((zmedi-bordlipbot)/lipbufthick)
3506 !C lipbufthick is thickenes of lipid buffore
3507          sslipi=sscalelip(fracinbuf)
3508          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3509         elseif (zmedi.gt.bufliptop) then
3510          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3511          sslipi=sscalelip(fracinbuf)
3512          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3513         else
3514          sslipi=1.0d0
3515          ssgradlipi=0.0
3516         endif
3517        else
3518          sslipi=0.0d0
3519          ssgradlipi=0.0
3520        endif
3521 !       print *,i,sslipi,ssgradlipi
3522        call eelecij(i,i+2,ees,evdw1,eel_loc)
3523         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3524         num_cont_hb(i)=num_conti
3525       enddo
3526       do i=iturn4_start,iturn4_end
3527         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3528           .or. itype(i+3,1).eq.ntyp1 &
3529           .or. itype(i+4,1).eq.ntyp1) cycle
3530 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3531         dxi=dc(1,i)
3532         dyi=dc(2,i)
3533         dzi=dc(3,i)
3534         dx_normi=dc_norm(1,i)
3535         dy_normi=dc_norm(2,i)
3536         dz_normi=dc_norm(3,i)
3537         xmedi=c(1,i)+0.5d0*dxi
3538         ymedi=c(2,i)+0.5d0*dyi
3539         zmedi=c(3,i)+0.5d0*dzi
3540           xmedi=dmod(xmedi,boxxsize)
3541           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3542           ymedi=dmod(ymedi,boxysize)
3543           if (ymedi.lt.0) ymedi=ymedi+boxysize
3544           zmedi=dmod(zmedi,boxzsize)
3545           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3546        if ((zmedi.gt.bordlipbot)  &
3547        .and.(zmedi.lt.bordliptop)) then
3548 !C the energy transfer exist
3549         if (zmedi.lt.buflipbot) then
3550 !C what fraction I am in
3551          fracinbuf=1.0d0- &
3552              ((zmedi-bordlipbot)/lipbufthick)
3553 !C lipbufthick is thickenes of lipid buffore
3554          sslipi=sscalelip(fracinbuf)
3555          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3556         elseif (zmedi.gt.bufliptop) then
3557          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3558          sslipi=sscalelip(fracinbuf)
3559          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3560         else
3561          sslipi=1.0d0
3562          ssgradlipi=0.0
3563         endif
3564        else
3565          sslipi=0.0d0
3566          ssgradlipi=0.0
3567        endif
3568
3569         num_conti=num_cont_hb(i)
3570         call eelecij(i,i+3,ees,evdw1,eel_loc)
3571         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3572          call eturn4(i,eello_turn4)
3573 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3574         num_cont_hb(i)=num_conti
3575       enddo   ! i
3576 !
3577 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3578 !
3579 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3580       do i=iatel_s,iatel_e
3581         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3582         dxi=dc(1,i)
3583         dyi=dc(2,i)
3584         dzi=dc(3,i)
3585         dx_normi=dc_norm(1,i)
3586         dy_normi=dc_norm(2,i)
3587         dz_normi=dc_norm(3,i)
3588         xmedi=c(1,i)+0.5d0*dxi
3589         ymedi=c(2,i)+0.5d0*dyi
3590         zmedi=c(3,i)+0.5d0*dzi
3591           xmedi=dmod(xmedi,boxxsize)
3592           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3593           ymedi=dmod(ymedi,boxysize)
3594           if (ymedi.lt.0) ymedi=ymedi+boxysize
3595           zmedi=dmod(zmedi,boxzsize)
3596           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3597        if ((zmedi.gt.bordlipbot)  &
3598         .and.(zmedi.lt.bordliptop)) then
3599 !C the energy transfer exist
3600         if (zmedi.lt.buflipbot) then
3601 !C what fraction I am in
3602          fracinbuf=1.0d0- &
3603              ((zmedi-bordlipbot)/lipbufthick)
3604 !C lipbufthick is thickenes of lipid buffore
3605          sslipi=sscalelip(fracinbuf)
3606          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3607         elseif (zmedi.gt.bufliptop) then
3608          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3609          sslipi=sscalelip(fracinbuf)
3610          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3611         else
3612          sslipi=1.0d0
3613          ssgradlipi=0.0
3614         endif
3615        else
3616          sslipi=0.0d0
3617          ssgradlipi=0.0
3618        endif
3619
3620 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3621         num_conti=num_cont_hb(i)
3622         do j=ielstart(i),ielend(i)
3623 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3624           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3625           call eelecij(i,j,ees,evdw1,eel_loc)
3626         enddo ! j
3627         num_cont_hb(i)=num_conti
3628       enddo   ! i
3629 !      write (iout,*) "Number of loop steps in EELEC:",ind
3630 !d      do i=1,nres
3631 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3632 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3633 !d      enddo
3634 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3635 !cc      eel_loc=eel_loc+eello_turn3
3636 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3637       return
3638       end subroutine eelec
3639 !-----------------------------------------------------------------------------
3640       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3641
3642       use comm_locel
3643 !      implicit real*8 (a-h,o-z)
3644 !      include 'DIMENSIONS'
3645 #ifdef MPI
3646       include "mpif.h"
3647 #endif
3648 !      include 'COMMON.CONTROL'
3649 !      include 'COMMON.IOUNITS'
3650 !      include 'COMMON.GEO'
3651 !      include 'COMMON.VAR'
3652 !      include 'COMMON.LOCAL'
3653 !      include 'COMMON.CHAIN'
3654 !      include 'COMMON.DERIV'
3655 !      include 'COMMON.INTERACT'
3656 !      include 'COMMON.CONTACTS'
3657 !      include 'COMMON.TORSION'
3658 !      include 'COMMON.VECTORS'
3659 !      include 'COMMON.FFIELD'
3660 !      include 'COMMON.TIME1'
3661       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3662       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3663       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3664 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3665       real(kind=8),dimension(4) :: muij
3666       real(kind=8) :: geel_loc_ij,geel_loc_ji
3667       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3668                     dist_temp, dist_init,rlocshield,fracinbuf
3669       integer xshift,yshift,zshift,ilist,iresshield
3670 !el      integer :: num_conti,j1,j2
3671 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3672 !el        dz_normi,xmedi,ymedi,zmedi
3673
3674 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3675 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3676 !el          num_conti,j1,j2
3677
3678 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3679 #ifdef MOMENT
3680       real(kind=8) :: scal_el=1.0d0
3681 #else
3682       real(kind=8) :: scal_el=0.5d0
3683 #endif
3684 ! 12/13/98
3685 ! 13-go grudnia roku pamietnego...
3686       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3687                                              0.0d0,1.0d0,0.0d0,&
3688                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3689 !      integer :: maxconts=nres/4
3690 !el local variables
3691       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3692       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3693       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3694       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3695                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3696                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3697                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3698                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3699                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3700                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3701                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3702 !      maxconts=nres/4
3703 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3704 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3705
3706 !          time00=MPI_Wtime()
3707 !d      write (iout,*) "eelecij",i,j
3708 !          ind=ind+1
3709           iteli=itel(i)
3710           itelj=itel(j)
3711           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3712           aaa=app(iteli,itelj)
3713           bbb=bpp(iteli,itelj)
3714           ael6i=ael6(iteli,itelj)
3715           ael3i=ael3(iteli,itelj)
3716           dxj=dc(1,j)
3717           dyj=dc(2,j)
3718           dzj=dc(3,j)
3719           dx_normj=dc_norm(1,j)
3720           dy_normj=dc_norm(2,j)
3721           dz_normj=dc_norm(3,j)
3722 !          xj=c(1,j)+0.5D0*dxj-xmedi
3723 !          yj=c(2,j)+0.5D0*dyj-ymedi
3724 !          zj=c(3,j)+0.5D0*dzj-zmedi
3725           xj=c(1,j)+0.5D0*dxj
3726           yj=c(2,j)+0.5D0*dyj
3727           zj=c(3,j)+0.5D0*dzj
3728           xj=mod(xj,boxxsize)
3729           if (xj.lt.0) xj=xj+boxxsize
3730           yj=mod(yj,boxysize)
3731           if (yj.lt.0) yj=yj+boxysize
3732           zj=mod(zj,boxzsize)
3733           if (zj.lt.0) zj=zj+boxzsize
3734        if ((zj.gt.bordlipbot)  &
3735        .and.(zj.lt.bordliptop)) then
3736 !C the energy transfer exist
3737         if (zj.lt.buflipbot) then
3738 !C what fraction I am in
3739          fracinbuf=1.0d0-     &
3740              ((zj-bordlipbot)/lipbufthick)
3741 !C lipbufthick is thickenes of lipid buffore
3742          sslipj=sscalelip(fracinbuf)
3743          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3744         elseif (zj.gt.bufliptop) then
3745          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3746          sslipj=sscalelip(fracinbuf)
3747          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3748         else
3749          sslipj=1.0d0
3750          ssgradlipj=0.0
3751         endif
3752        else
3753          sslipj=0.0d0
3754          ssgradlipj=0.0
3755        endif
3756
3757       isubchap=0
3758       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3759       xj_safe=xj
3760       yj_safe=yj
3761       zj_safe=zj
3762       do xshift=-1,1
3763       do yshift=-1,1
3764       do zshift=-1,1
3765           xj=xj_safe+xshift*boxxsize
3766           yj=yj_safe+yshift*boxysize
3767           zj=zj_safe+zshift*boxzsize
3768           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3769           if(dist_temp.lt.dist_init) then
3770             dist_init=dist_temp
3771             xj_temp=xj
3772             yj_temp=yj
3773             zj_temp=zj
3774             isubchap=1
3775           endif
3776        enddo
3777        enddo
3778        enddo
3779        if (isubchap.eq.1) then
3780 !C          print *,i,j
3781           xj=xj_temp-xmedi
3782           yj=yj_temp-ymedi
3783           zj=zj_temp-zmedi
3784        else
3785           xj=xj_safe-xmedi
3786           yj=yj_safe-ymedi
3787           zj=zj_safe-zmedi
3788        endif
3789
3790           rij=xj*xj+yj*yj+zj*zj
3791           rrmij=1.0D0/rij
3792           rij=dsqrt(rij)
3793 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3794             sss_ele_cut=sscale_ele(rij)
3795             sss_ele_grad=sscagrad_ele(rij)
3796 !             sss_ele_cut=1.0d0
3797 !             sss_ele_grad=0.0d0
3798 !            print *,sss_ele_cut,sss_ele_grad,&
3799 !            (rij),r_cut_ele,rlamb_ele
3800 !            if (sss_ele_cut.le.0.0) go to 128
3801
3802           rmij=1.0D0/rij
3803           r3ij=rrmij*rmij
3804           r6ij=r3ij*r3ij
3805           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3806           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3807           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3808           fac=cosa-3.0D0*cosb*cosg
3809           ev1=aaa*r6ij*r6ij
3810 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3811           if (j.eq.i+2) ev1=scal_el*ev1
3812           ev2=bbb*r6ij
3813           fac3=ael6i*r6ij
3814           fac4=ael3i*r3ij
3815           evdwij=ev1+ev2
3816           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3817           el2=fac4*fac
3818 !          eesij=el1+el2
3819           if (shield_mode.gt.0) then
3820 !C          fac_shield(i)=0.4
3821 !C          fac_shield(j)=0.6
3822           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3823           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3824           eesij=(el1+el2)
3825           ees=ees+eesij*sss_ele_cut
3826 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3827 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3828           else
3829           fac_shield(i)=1.0
3830           fac_shield(j)=1.0
3831           eesij=(el1+el2)
3832           ees=ees+eesij   &
3833             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3834 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3835           endif
3836
3837 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3838           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3839 !          ees=ees+eesij*sss_ele_cut
3840           evdw1=evdw1+evdwij*sss_ele_cut  &
3841            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3842 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3843 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3844 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3845 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3846
3847           if (energy_dec) then
3848 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3849 !                  'evdw1',i,j,evdwij,&
3850 !                  iteli,itelj,aaa,evdw1
3851               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3852               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3853           endif
3854 !
3855 ! Calculate contributions to the Cartesian gradient.
3856 !
3857 #ifdef SPLITELE
3858           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3859               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3860           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3861              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3862           fac1=fac
3863           erij(1)=xj*rmij
3864           erij(2)=yj*rmij
3865           erij(3)=zj*rmij
3866 !
3867 ! Radial derivatives. First process both termini of the fragment (i,j)
3868 !
3869           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3870           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3871           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3872            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3873           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3874             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3875
3876           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3877           (shield_mode.gt.0)) then
3878 !C          print *,i,j
3879           do ilist=1,ishield_list(i)
3880            iresshield=shield_list(ilist,i)
3881            do k=1,3
3882            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3883            *2.0*sss_ele_cut
3884            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3885                    rlocshield &
3886             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3887             *sss_ele_cut
3888             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3889            enddo
3890           enddo
3891           do ilist=1,ishield_list(j)
3892            iresshield=shield_list(ilist,j)
3893            do k=1,3
3894            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3895           *2.0*sss_ele_cut
3896            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3897                    rlocshield &
3898            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3899            *sss_ele_cut
3900            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3901            enddo
3902           enddo
3903           do k=1,3
3904             gshieldc(k,i)=gshieldc(k,i)+ &
3905                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3906            *sss_ele_cut
3907
3908             gshieldc(k,j)=gshieldc(k,j)+ &
3909                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3910            *sss_ele_cut
3911
3912             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3913                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3914            *sss_ele_cut
3915
3916             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3917                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3918            *sss_ele_cut
3919
3920            enddo
3921            endif
3922
3923
3924 !          do k=1,3
3925 !            ghalf=0.5D0*ggg(k)
3926 !            gelc(k,i)=gelc(k,i)+ghalf
3927 !            gelc(k,j)=gelc(k,j)+ghalf
3928 !          enddo
3929 ! 9/28/08 AL Gradient compotents will be summed only at the end
3930           do k=1,3
3931             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3932             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3933           enddo
3934             gelc_long(3,j)=gelc_long(3,j)+  &
3935           ssgradlipj*eesij/2.0d0*lipscale**2&
3936            *sss_ele_cut
3937
3938             gelc_long(3,i)=gelc_long(3,i)+  &
3939           ssgradlipi*eesij/2.0d0*lipscale**2&
3940            *sss_ele_cut
3941
3942
3943 !
3944 ! Loop over residues i+1 thru j-1.
3945 !
3946 !grad          do k=i+1,j-1
3947 !grad            do l=1,3
3948 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3949 !grad            enddo
3950 !grad          enddo
3951           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3952            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3953           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3954            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3955           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3956            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3957
3958 !          do k=1,3
3959 !            ghalf=0.5D0*ggg(k)
3960 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3961 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3962 !          enddo
3963 ! 9/28/08 AL Gradient compotents will be summed only at the end
3964           do k=1,3
3965             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3966             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3967           enddo
3968
3969 !C Lipidic part for scaling weight
3970            gvdwpp(3,j)=gvdwpp(3,j)+ &
3971           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3972            gvdwpp(3,i)=gvdwpp(3,i)+ &
3973           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3974 !! Loop over residues i+1 thru j-1.
3975 !
3976 !grad          do k=i+1,j-1
3977 !grad            do l=1,3
3978 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3979 !grad            enddo
3980 !grad          enddo
3981 #else
3982           facvdw=(ev1+evdwij)*sss_ele_cut &
3983            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3984
3985           facel=(el1+eesij)*sss_ele_cut
3986           fac1=fac
3987           fac=-3*rrmij*(facvdw+facvdw+facel)
3988           erij(1)=xj*rmij
3989           erij(2)=yj*rmij
3990           erij(3)=zj*rmij
3991 !
3992 ! Radial derivatives. First process both termini of the fragment (i,j)
3993 !
3994           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3995           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3996           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3997 !          do k=1,3
3998 !            ghalf=0.5D0*ggg(k)
3999 !            gelc(k,i)=gelc(k,i)+ghalf
4000 !            gelc(k,j)=gelc(k,j)+ghalf
4001 !          enddo
4002 ! 9/28/08 AL Gradient compotents will be summed only at the end
4003           do k=1,3
4004             gelc_long(k,j)=gelc(k,j)+ggg(k)
4005             gelc_long(k,i)=gelc(k,i)-ggg(k)
4006           enddo
4007 !
4008 ! Loop over residues i+1 thru j-1.
4009 !
4010 !grad          do k=i+1,j-1
4011 !grad            do l=1,3
4012 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4013 !grad            enddo
4014 !grad          enddo
4015 ! 9/28/08 AL Gradient compotents will be summed only at the end
4016           ggg(1)=facvdw*xj &
4017            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4018           ggg(2)=facvdw*yj &
4019            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4020           ggg(3)=facvdw*zj &
4021            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4022
4023           do k=1,3
4024             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4025             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4026           enddo
4027            gvdwpp(3,j)=gvdwpp(3,j)+ &
4028           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4029            gvdwpp(3,i)=gvdwpp(3,i)+ &
4030           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4031
4032 #endif
4033 !
4034 ! Angular part
4035 !
4036           ecosa=2.0D0*fac3*fac1+fac4
4037           fac4=-3.0D0*fac4
4038           fac3=-6.0D0*fac3
4039           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4040           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4041           do k=1,3
4042             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4043             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4044           enddo
4045 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4046 !d   &          (dcosg(k),k=1,3)
4047           do k=1,3
4048             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4049              *fac_shield(i)**2*fac_shield(j)**2 &
4050              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4051
4052           enddo
4053 !          do k=1,3
4054 !            ghalf=0.5D0*ggg(k)
4055 !            gelc(k,i)=gelc(k,i)+ghalf
4056 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4057 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4058 !            gelc(k,j)=gelc(k,j)+ghalf
4059 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4060 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4061 !          enddo
4062 !grad          do k=i+1,j-1
4063 !grad            do l=1,3
4064 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4065 !grad            enddo
4066 !grad          enddo
4067           do k=1,3
4068             gelc(k,i)=gelc(k,i) &
4069                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4070                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4071                      *sss_ele_cut &
4072                      *fac_shield(i)**2*fac_shield(j)**2 &
4073                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4074
4075             gelc(k,j)=gelc(k,j) &
4076                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4077                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4078                      *sss_ele_cut  &
4079                      *fac_shield(i)**2*fac_shield(j)**2  &
4080                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4081
4082             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4083             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4084           enddo
4085
4086           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4087               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4088               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4089 !
4090 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4091 !   energy of a peptide unit is assumed in the form of a second-order
4092 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4093 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4094 !   are computed for EVERY pair of non-contiguous peptide groups.
4095 !
4096           if (j.lt.nres-1) then
4097             j1=j+1
4098             j2=j-1
4099           else
4100             j1=j-1
4101             j2=j-2
4102           endif
4103           kkk=0
4104           do k=1,2
4105             do l=1,2
4106               kkk=kkk+1
4107               muij(kkk)=mu(k,i)*mu(l,j)
4108 #ifdef NEWCORR
4109              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4110 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4111              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4112              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4113 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4114              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4115 #endif
4116
4117             enddo
4118           enddo
4119 !d         write (iout,*) 'EELEC: i',i,' j',j
4120 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4121 !d          write(iout,*) 'muij',muij
4122           ury=scalar(uy(1,i),erij)
4123           urz=scalar(uz(1,i),erij)
4124           vry=scalar(uy(1,j),erij)
4125           vrz=scalar(uz(1,j),erij)
4126           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4127           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4128           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4129           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4130           fac=dsqrt(-ael6i)*r3ij
4131           a22=a22*fac
4132           a23=a23*fac
4133           a32=a32*fac
4134           a33=a33*fac
4135 !d          write (iout,'(4i5,4f10.5)')
4136 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4137 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4138 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4139 !d     &      uy(:,j),uz(:,j)
4140 !d          write (iout,'(4f10.5)')
4141 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4142 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4143 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4144 !d           write (iout,'(9f10.5/)')
4145 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4146 ! Derivatives of the elements of A in virtual-bond vectors
4147           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4148           do k=1,3
4149             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4150             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4151             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4152             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4153             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4154             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4155             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4156             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4157             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4158             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4159             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4160             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4161           enddo
4162 ! Compute radial contributions to the gradient
4163           facr=-3.0d0*rrmij
4164           a22der=a22*facr
4165           a23der=a23*facr
4166           a32der=a32*facr
4167           a33der=a33*facr
4168           agg(1,1)=a22der*xj
4169           agg(2,1)=a22der*yj
4170           agg(3,1)=a22der*zj
4171           agg(1,2)=a23der*xj
4172           agg(2,2)=a23der*yj
4173           agg(3,2)=a23der*zj
4174           agg(1,3)=a32der*xj
4175           agg(2,3)=a32der*yj
4176           agg(3,3)=a32der*zj
4177           agg(1,4)=a33der*xj
4178           agg(2,4)=a33der*yj
4179           agg(3,4)=a33der*zj
4180 ! Add the contributions coming from er
4181           fac3=-3.0d0*fac
4182           do k=1,3
4183             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4184             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4185             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4186             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4187           enddo
4188           do k=1,3
4189 ! Derivatives in DC(i)
4190 !grad            ghalf1=0.5d0*agg(k,1)
4191 !grad            ghalf2=0.5d0*agg(k,2)
4192 !grad            ghalf3=0.5d0*agg(k,3)
4193 !grad            ghalf4=0.5d0*agg(k,4)
4194             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4195             -3.0d0*uryg(k,2)*vry)!+ghalf1
4196             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4197             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4198             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4199             -3.0d0*urzg(k,2)*vry)!+ghalf3
4200             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4201             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4202 ! Derivatives in DC(i+1)
4203             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4204             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4205             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4206             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4207             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4208             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4209             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4210             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4211 ! Derivatives in DC(j)
4212             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4213             -3.0d0*vryg(k,2)*ury)!+ghalf1
4214             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4215             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4216             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4217             -3.0d0*vryg(k,2)*urz)!+ghalf3
4218             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4219             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4220 ! Derivatives in DC(j+1) or DC(nres-1)
4221             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4222             -3.0d0*vryg(k,3)*ury)
4223             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4224             -3.0d0*vrzg(k,3)*ury)
4225             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4226             -3.0d0*vryg(k,3)*urz)
4227             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4228             -3.0d0*vrzg(k,3)*urz)
4229 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4230 !grad              do l=1,4
4231 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4232 !grad              enddo
4233 !grad            endif
4234           enddo
4235           acipa(1,1)=a22
4236           acipa(1,2)=a23
4237           acipa(2,1)=a32
4238           acipa(2,2)=a33
4239           a22=-a22
4240           a23=-a23
4241           do l=1,2
4242             do k=1,3
4243               agg(k,l)=-agg(k,l)
4244               aggi(k,l)=-aggi(k,l)
4245               aggi1(k,l)=-aggi1(k,l)
4246               aggj(k,l)=-aggj(k,l)
4247               aggj1(k,l)=-aggj1(k,l)
4248             enddo
4249           enddo
4250           if (j.lt.nres-1) then
4251             a22=-a22
4252             a32=-a32
4253             do l=1,3,2
4254               do k=1,3
4255                 agg(k,l)=-agg(k,l)
4256                 aggi(k,l)=-aggi(k,l)
4257                 aggi1(k,l)=-aggi1(k,l)
4258                 aggj(k,l)=-aggj(k,l)
4259                 aggj1(k,l)=-aggj1(k,l)
4260               enddo
4261             enddo
4262           else
4263             a22=-a22
4264             a23=-a23
4265             a32=-a32
4266             a33=-a33
4267             do l=1,4
4268               do k=1,3
4269                 agg(k,l)=-agg(k,l)
4270                 aggi(k,l)=-aggi(k,l)
4271                 aggi1(k,l)=-aggi1(k,l)
4272                 aggj(k,l)=-aggj(k,l)
4273                 aggj1(k,l)=-aggj1(k,l)
4274               enddo
4275             enddo
4276           endif
4277           ENDIF ! WCORR
4278           IF (wel_loc.gt.0.0d0) THEN
4279 ! Contribution to the local-electrostatic energy coming from the i-j pair
4280           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4281            +a33*muij(4)
4282           if (shield_mode.eq.0) then
4283            fac_shield(i)=1.0
4284            fac_shield(j)=1.0
4285           endif
4286           eel_loc_ij=eel_loc_ij &
4287          *fac_shield(i)*fac_shield(j) &
4288          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4289 !C Now derivative over eel_loc
4290           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4291          (shield_mode.gt.0)) then
4292 !C          print *,i,j
4293
4294           do ilist=1,ishield_list(i)
4295            iresshield=shield_list(ilist,i)
4296            do k=1,3
4297            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4298                                                 /fac_shield(i)&
4299            *sss_ele_cut
4300            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4301                    rlocshield  &
4302           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4303           *sss_ele_cut
4304
4305             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4306            +rlocshield
4307            enddo
4308           enddo
4309           do ilist=1,ishield_list(j)
4310            iresshield=shield_list(ilist,j)
4311            do k=1,3
4312            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4313                                             /fac_shield(j)   &
4314             *sss_ele_cut
4315            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4316                    rlocshield  &
4317       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4318        *sss_ele_cut
4319
4320            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4321                   +rlocshield
4322
4323            enddo
4324           enddo
4325
4326           do k=1,3
4327             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4328                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4329                     *sss_ele_cut
4330             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4331                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4332                     *sss_ele_cut
4333             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4334                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4335                     *sss_ele_cut
4336             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4337                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4338                     *sss_ele_cut
4339
4340            enddo
4341            endif
4342
4343 #ifdef NEWCORR
4344          geel_loc_ij=(a22*gmuij1(1)&
4345           +a23*gmuij1(2)&
4346           +a32*gmuij1(3)&
4347           +a33*gmuij1(4))&
4348          *fac_shield(i)*fac_shield(j)&
4349                     *sss_ele_cut
4350
4351 !c         write(iout,*) "derivative over thatai"
4352 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4353 !c     &   a33*gmuij1(4)
4354          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4355            geel_loc_ij*wel_loc
4356 !c         write(iout,*) "derivative over thatai-1"
4357 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4358 !c     &   a33*gmuij2(4)
4359          geel_loc_ij=&
4360           a22*gmuij2(1)&
4361           +a23*gmuij2(2)&
4362           +a32*gmuij2(3)&
4363           +a33*gmuij2(4)
4364          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4365            geel_loc_ij*wel_loc&
4366          *fac_shield(i)*fac_shield(j)&
4367                     *sss_ele_cut
4368
4369
4370 !c  Derivative over j residue
4371          geel_loc_ji=a22*gmuji1(1)&
4372           +a23*gmuji1(2)&
4373           +a32*gmuji1(3)&
4374           +a33*gmuji1(4)
4375 !c         write(iout,*) "derivative over thataj"
4376 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4377 !c     &   a33*gmuji1(4)
4378
4379         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4380            geel_loc_ji*wel_loc&
4381          *fac_shield(i)*fac_shield(j)&
4382                     *sss_ele_cut
4383
4384
4385          geel_loc_ji=&
4386           +a22*gmuji2(1)&
4387           +a23*gmuji2(2)&
4388           +a32*gmuji2(3)&
4389           +a33*gmuji2(4)
4390 !c         write(iout,*) "derivative over thataj-1"
4391 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4392 !c     &   a33*gmuji2(4)
4393          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4394            geel_loc_ji*wel_loc&
4395          *fac_shield(i)*fac_shield(j)&
4396                     *sss_ele_cut
4397 #endif
4398
4399 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4400 !           eel_loc_ij=0.0
4401 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4402 !                  'eelloc',i,j,eel_loc_ij
4403           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4404                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4405 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4406
4407 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4408 !          if (energy_dec) write (iout,*) "muij",muij
4409 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4410
4411           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4412 ! Partial derivatives in virtual-bond dihedral angles gamma
4413           if (i.gt.1) &
4414           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4415                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4416                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4417                  *sss_ele_cut  &
4418           *fac_shield(i)*fac_shield(j) &
4419           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4420
4421           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4422                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4423                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4424                  *sss_ele_cut &
4425           *fac_shield(i)*fac_shield(j) &
4426           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4427 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4428 !          do l=1,3
4429 !            ggg(1)=(agg(1,1)*muij(1)+ &
4430 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4431 !            *sss_ele_cut &
4432 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4433 !            ggg(2)=(agg(2,1)*muij(1)+ &
4434 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4435 !            *sss_ele_cut &
4436 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4437 !            ggg(3)=(agg(3,1)*muij(1)+ &
4438 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4439 !            *sss_ele_cut &
4440 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4441            xtemp(1)=xj
4442            xtemp(2)=yj
4443            xtemp(3)=zj
4444
4445            do l=1,3
4446             ggg(l)=(agg(l,1)*muij(1)+ &
4447                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4448             *sss_ele_cut &
4449           *fac_shield(i)*fac_shield(j) &
4450           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4451              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4452
4453
4454             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4455             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4456 !grad            ghalf=0.5d0*ggg(l)
4457 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4458 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4459           enddo
4460             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4461           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4462           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4463
4464             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4465           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4466           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4467
4468 !grad          do k=i+1,j2
4469 !grad            do l=1,3
4470 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4471 !grad            enddo
4472 !grad          enddo
4473 ! Remaining derivatives of eello
4474           do l=1,3
4475             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4476                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4477             *sss_ele_cut &
4478           *fac_shield(i)*fac_shield(j) &
4479           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4480
4481 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4482             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4483                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4484             +aggi1(l,4)*muij(4))&
4485             *sss_ele_cut &
4486           *fac_shield(i)*fac_shield(j) &
4487           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4488
4489 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4490             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4491                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4492             *sss_ele_cut &
4493           *fac_shield(i)*fac_shield(j) &
4494           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4495
4496 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4497             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4498                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4499             +aggj1(l,4)*muij(4))&
4500             *sss_ele_cut &
4501           *fac_shield(i)*fac_shield(j) &
4502          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4503
4504 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4505           enddo
4506           ENDIF
4507 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4508 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4509           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4510              .and. num_conti.le.maxconts) then
4511 !            write (iout,*) i,j," entered corr"
4512 !
4513 ! Calculate the contact function. The ith column of the array JCONT will
4514 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4515 ! greater than I). The arrays FACONT and GACONT will contain the values of
4516 ! the contact function and its derivative.
4517 !           r0ij=1.02D0*rpp(iteli,itelj)
4518 !           r0ij=1.11D0*rpp(iteli,itelj)
4519             r0ij=2.20D0*rpp(iteli,itelj)
4520 !           r0ij=1.55D0*rpp(iteli,itelj)
4521             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4522 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4523             if (fcont.gt.0.0D0) then
4524               num_conti=num_conti+1
4525               if (num_conti.gt.maxconts) then
4526 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4527 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4528                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4529                                ' will skip next contacts for this conf.', num_conti
4530               else
4531                 jcont_hb(num_conti,i)=j
4532 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4533 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4534                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4535                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4536 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4537 !  terms.
4538                 d_cont(num_conti,i)=rij
4539 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4540 !     --- Electrostatic-interaction matrix ---
4541                 a_chuj(1,1,num_conti,i)=a22
4542                 a_chuj(1,2,num_conti,i)=a23
4543                 a_chuj(2,1,num_conti,i)=a32
4544                 a_chuj(2,2,num_conti,i)=a33
4545 !     --- Gradient of rij
4546                 do kkk=1,3
4547                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4548                 enddo
4549                 kkll=0
4550                 do k=1,2
4551                   do l=1,2
4552                     kkll=kkll+1
4553                     do m=1,3
4554                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4555                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4556                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4557                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4558                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4559                     enddo
4560                   enddo
4561                 enddo
4562                 ENDIF
4563                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4564 ! Calculate contact energies
4565                 cosa4=4.0D0*cosa
4566                 wij=cosa-3.0D0*cosb*cosg
4567                 cosbg1=cosb+cosg
4568                 cosbg2=cosb-cosg
4569 !               fac3=dsqrt(-ael6i)/r0ij**3
4570                 fac3=dsqrt(-ael6i)*r3ij
4571 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4572                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4573                 if (ees0tmp.gt.0) then
4574                   ees0pij=dsqrt(ees0tmp)
4575                 else
4576                   ees0pij=0
4577                 endif
4578                 if (shield_mode.eq.0) then
4579                 fac_shield(i)=1.0d0
4580                 fac_shield(j)=1.0d0
4581                 else
4582                 ees0plist(num_conti,i)=j
4583                 endif
4584 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4585                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4586                 if (ees0tmp.gt.0) then
4587                   ees0mij=dsqrt(ees0tmp)
4588                 else
4589                   ees0mij=0
4590                 endif
4591 !               ees0mij=0.0D0
4592                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4593                      *sss_ele_cut &
4594                      *fac_shield(i)*fac_shield(j)
4595
4596                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4597                      *sss_ele_cut &
4598                      *fac_shield(i)*fac_shield(j)
4599
4600 ! Diagnostics. Comment out or remove after debugging!
4601 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4602 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4603 !               ees0m(num_conti,i)=0.0D0
4604 ! End diagnostics.
4605 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4606 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4607 ! Angular derivatives of the contact function
4608                 ees0pij1=fac3/ees0pij
4609                 ees0mij1=fac3/ees0mij
4610                 fac3p=-3.0D0*fac3*rrmij
4611                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4612                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4613 !               ees0mij1=0.0D0
4614                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4615                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4616                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4617                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4618                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4619                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4620                 ecosap=ecosa1+ecosa2
4621                 ecosbp=ecosb1+ecosb2
4622                 ecosgp=ecosg1+ecosg2
4623                 ecosam=ecosa1-ecosa2
4624                 ecosbm=ecosb1-ecosb2
4625                 ecosgm=ecosg1-ecosg2
4626 ! Diagnostics
4627 !               ecosap=ecosa1
4628 !               ecosbp=ecosb1
4629 !               ecosgp=ecosg1
4630 !               ecosam=0.0D0
4631 !               ecosbm=0.0D0
4632 !               ecosgm=0.0D0
4633 ! End diagnostics
4634                 facont_hb(num_conti,i)=fcont
4635                 fprimcont=fprimcont/rij
4636 !d              facont_hb(num_conti,i)=1.0D0
4637 ! Following line is for diagnostics.
4638 !d              fprimcont=0.0D0
4639                 do k=1,3
4640                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4641                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4642                 enddo
4643                 do k=1,3
4644                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4645                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4646                 enddo
4647                 gggp(1)=gggp(1)+ees0pijp*xj &
4648                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4649                 gggp(2)=gggp(2)+ees0pijp*yj &
4650                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4651                 gggp(3)=gggp(3)+ees0pijp*zj &
4652                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4653
4654                 gggm(1)=gggm(1)+ees0mijp*xj &
4655                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4656
4657                 gggm(2)=gggm(2)+ees0mijp*yj &
4658                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4659
4660                 gggm(3)=gggm(3)+ees0mijp*zj &
4661                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4662
4663 ! Derivatives due to the contact function
4664                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4665                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4666                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4667                 do k=1,3
4668 !
4669 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4670 !          following the change of gradient-summation algorithm.
4671 !
4672 !grad                  ghalfp=0.5D0*gggp(k)
4673 !grad                  ghalfm=0.5D0*gggm(k)
4674                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4675                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4676                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4677                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4678
4679                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4680                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4681                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4682                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4683
4684                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4685                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4686
4687                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4688                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4689                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4690                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4691
4692                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4693                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4694                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4695                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4696
4697                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4698                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4699
4700                 enddo
4701 ! Diagnostics. Comment out or remove after debugging!
4702 !diag           do k=1,3
4703 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4704 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4705 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4706 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4707 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4708 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4709 !diag           enddo
4710               ENDIF ! wcorr
4711               endif  ! num_conti.le.maxconts
4712             endif  ! fcont.gt.0
4713           endif    ! j.gt.i+1
4714           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4715             do k=1,4
4716               do l=1,3
4717                 ghalf=0.5d0*agg(l,k)
4718                 aggi(l,k)=aggi(l,k)+ghalf
4719                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4720                 aggj(l,k)=aggj(l,k)+ghalf
4721               enddo
4722             enddo
4723             if (j.eq.nres-1 .and. i.lt.j-2) then
4724               do k=1,4
4725                 do l=1,3
4726                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4727                 enddo
4728               enddo
4729             endif
4730           endif
4731  128  continue
4732 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4733       return
4734       end subroutine eelecij
4735 !-----------------------------------------------------------------------------
4736       subroutine eturn3(i,eello_turn3)
4737 ! Third- and fourth-order contributions from turns
4738
4739       use comm_locel
4740 !      implicit real*8 (a-h,o-z)
4741 !      include 'DIMENSIONS'
4742 !      include 'COMMON.IOUNITS'
4743 !      include 'COMMON.GEO'
4744 !      include 'COMMON.VAR'
4745 !      include 'COMMON.LOCAL'
4746 !      include 'COMMON.CHAIN'
4747 !      include 'COMMON.DERIV'
4748 !      include 'COMMON.INTERACT'
4749 !      include 'COMMON.CONTACTS'
4750 !      include 'COMMON.TORSION'
4751 !      include 'COMMON.VECTORS'
4752 !      include 'COMMON.FFIELD'
4753 !      include 'COMMON.CONTROL'
4754       real(kind=8),dimension(3) :: ggg
4755       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4756         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4757        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4758
4759       real(kind=8),dimension(2) :: auxvec,auxvec1
4760 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4761       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4762 !el      integer :: num_conti,j1,j2
4763 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4764 !el        dz_normi,xmedi,ymedi,zmedi
4765
4766 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4767 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4768 !el         num_conti,j1,j2
4769 !el local variables
4770       integer :: i,j,l,k,ilist,iresshield
4771       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4772
4773       j=i+2
4774 !      write (iout,*) "eturn3",i,j,j1,j2
4775           zj=(c(3,j)+c(3,j+1))/2.0d0
4776           zj=mod(zj,boxzsize)
4777           if (zj.lt.0) zj=zj+boxzsize
4778           if ((zj.lt.0)) write (*,*) "CHUJ"
4779        if ((zj.gt.bordlipbot)  &
4780         .and.(zj.lt.bordliptop)) then
4781 !C the energy transfer exist
4782         if (zj.lt.buflipbot) then
4783 !C what fraction I am in
4784          fracinbuf=1.0d0-     &
4785              ((zj-bordlipbot)/lipbufthick)
4786 !C lipbufthick is thickenes of lipid buffore
4787          sslipj=sscalelip(fracinbuf)
4788          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4789         elseif (zj.gt.bufliptop) then
4790          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4791          sslipj=sscalelip(fracinbuf)
4792          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4793         else
4794          sslipj=1.0d0
4795          ssgradlipj=0.0
4796         endif
4797        else
4798          sslipj=0.0d0
4799          ssgradlipj=0.0
4800        endif
4801
4802       a_temp(1,1)=a22
4803       a_temp(1,2)=a23
4804       a_temp(2,1)=a32
4805       a_temp(2,2)=a33
4806 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4807 !
4808 !               Third-order contributions
4809 !
4810 !                 (i+2)o----(i+3)
4811 !                      | |
4812 !                      | |
4813 !                 (i+1)o----i
4814 !
4815 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4816 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4817         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4818         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4819         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4820         call transpose2(auxmat(1,1),auxmat1(1,1))
4821         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4822         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4823         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4824         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4825         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4826
4827         if (shield_mode.eq.0) then
4828         fac_shield(i)=1.0d0
4829         fac_shield(j)=1.0d0
4830         endif
4831
4832         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4833          *fac_shield(i)*fac_shield(j)  &
4834          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4835         eello_t3= &
4836         0.5d0*(pizda(1,1)+pizda(2,2)) &
4837         *fac_shield(i)*fac_shield(j)
4838
4839         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4840                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4841 !C#ifdef NEWCORR
4842 !C Derivatives in theta
4843         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4844        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4845         *fac_shield(i)*fac_shield(j)
4846         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4847        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4848         *fac_shield(i)*fac_shield(j)
4849 !C#endif
4850
4851
4852
4853           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4854        (shield_mode.gt.0)) then
4855 !C          print *,i,j
4856
4857           do ilist=1,ishield_list(i)
4858            iresshield=shield_list(ilist,i)
4859            do k=1,3
4860            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4861            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4862                    rlocshield &
4863            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4864             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4865              +rlocshield
4866            enddo
4867           enddo
4868           do ilist=1,ishield_list(j)
4869            iresshield=shield_list(ilist,j)
4870            do k=1,3
4871            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4872            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4873                    rlocshield &
4874            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4875            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4876                   +rlocshield
4877
4878            enddo
4879           enddo
4880
4881           do k=1,3
4882             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4883                    grad_shield(k,i)*eello_t3/fac_shield(i)
4884             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4885                    grad_shield(k,j)*eello_t3/fac_shield(j)
4886             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4887                    grad_shield(k,i)*eello_t3/fac_shield(i)
4888             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4889                    grad_shield(k,j)*eello_t3/fac_shield(j)
4890            enddo
4891            endif
4892
4893 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4894 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4895 !d     &    ' eello_turn3_num',4*eello_turn3_num
4896 ! Derivatives in gamma(i)
4897         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4898         call transpose2(auxmat2(1,1),auxmat3(1,1))
4899         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4900         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4901           *fac_shield(i)*fac_shield(j)        &
4902           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4903 ! Derivatives in gamma(i+1)
4904         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4905         call transpose2(auxmat2(1,1),auxmat3(1,1))
4906         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4907         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4908           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4909           *fac_shield(i)*fac_shield(j)        &
4910           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4911
4912 ! Cartesian derivatives
4913         do l=1,3
4914 !            ghalf1=0.5d0*agg(l,1)
4915 !            ghalf2=0.5d0*agg(l,2)
4916 !            ghalf3=0.5d0*agg(l,3)
4917 !            ghalf4=0.5d0*agg(l,4)
4918           a_temp(1,1)=aggi(l,1)!+ghalf1
4919           a_temp(1,2)=aggi(l,2)!+ghalf2
4920           a_temp(2,1)=aggi(l,3)!+ghalf3
4921           a_temp(2,2)=aggi(l,4)!+ghalf4
4922           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4923           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4924             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4925           *fac_shield(i)*fac_shield(j)      &
4926           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4927
4928           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4929           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4930           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4931           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4932           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4933           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4934             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4935           *fac_shield(i)*fac_shield(j)        &
4936           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4937
4938           a_temp(1,1)=aggj(l,1)!+ghalf1
4939           a_temp(1,2)=aggj(l,2)!+ghalf2
4940           a_temp(2,1)=aggj(l,3)!+ghalf3
4941           a_temp(2,2)=aggj(l,4)!+ghalf4
4942           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4943           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4944             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4945           *fac_shield(i)*fac_shield(j)      &
4946           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4947
4948           a_temp(1,1)=aggj1(l,1)
4949           a_temp(1,2)=aggj1(l,2)
4950           a_temp(2,1)=aggj1(l,3)
4951           a_temp(2,2)=aggj1(l,4)
4952           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4953           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4954             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4955           *fac_shield(i)*fac_shield(j)        &
4956           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4957         enddo
4958          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4959           ssgradlipi*eello_t3/4.0d0*lipscale
4960          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4961           ssgradlipj*eello_t3/4.0d0*lipscale
4962          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4963           ssgradlipi*eello_t3/4.0d0*lipscale
4964          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4965           ssgradlipj*eello_t3/4.0d0*lipscale
4966
4967       return
4968       end subroutine eturn3
4969 !-----------------------------------------------------------------------------
4970       subroutine eturn4(i,eello_turn4)
4971 ! Third- and fourth-order contributions from turns
4972
4973       use comm_locel
4974 !      implicit real*8 (a-h,o-z)
4975 !      include 'DIMENSIONS'
4976 !      include 'COMMON.IOUNITS'
4977 !      include 'COMMON.GEO'
4978 !      include 'COMMON.VAR'
4979 !      include 'COMMON.LOCAL'
4980 !      include 'COMMON.CHAIN'
4981 !      include 'COMMON.DERIV'
4982 !      include 'COMMON.INTERACT'
4983 !      include 'COMMON.CONTACTS'
4984 !      include 'COMMON.TORSION'
4985 !      include 'COMMON.VECTORS'
4986 !      include 'COMMON.FFIELD'
4987 !      include 'COMMON.CONTROL'
4988       real(kind=8),dimension(3) :: ggg
4989       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4990         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4991         gte1t,gte2t,gte3t,&
4992         gte1a,gtae3,gtae3e2, ae3gte2,&
4993         gtEpizda1,gtEpizda2,gtEpizda3
4994
4995       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4996        auxgEvec3,auxgvec
4997
4998 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4999       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5000 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5001 !el        dz_normi,xmedi,ymedi,zmedi
5002 !el      integer :: num_conti,j1,j2
5003 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5004 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5005 !el          num_conti,j1,j2
5006 !el local variables
5007       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5008       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5009          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5010
5011       j=i+3
5012 !      if (j.ne.20) return
5013 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5014 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5015 !
5016 !               Fourth-order contributions
5017 !
5018 !                 (i+3)o----(i+4)
5019 !                     /  |
5020 !               (i+2)o   |
5021 !                     \  |
5022 !                 (i+1)o----i
5023 !
5024 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5025 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5026 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5027           zj=(c(3,j)+c(3,j+1))/2.0d0
5028           zj=mod(zj,boxzsize)
5029           if (zj.lt.0) zj=zj+boxzsize
5030        if ((zj.gt.bordlipbot)  &
5031         .and.(zj.lt.bordliptop)) then
5032 !C the energy transfer exist
5033         if (zj.lt.buflipbot) then
5034 !C what fraction I am in
5035          fracinbuf=1.0d0-     &
5036              ((zj-bordlipbot)/lipbufthick)
5037 !C lipbufthick is thickenes of lipid buffore
5038          sslipj=sscalelip(fracinbuf)
5039          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5040         elseif (zj.gt.bufliptop) then
5041          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5042          sslipj=sscalelip(fracinbuf)
5043          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5044         else
5045          sslipj=1.0d0
5046          ssgradlipj=0.0
5047         endif
5048        else
5049          sslipj=0.0d0
5050          ssgradlipj=0.0
5051        endif
5052
5053         a_temp(1,1)=a22
5054         a_temp(1,2)=a23
5055         a_temp(2,1)=a32
5056         a_temp(2,2)=a33
5057         iti1=i+1
5058         iti2=i+2
5059         iti3=i+3
5060 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5061         call transpose2(EUg(1,1,i+1),e1t(1,1))
5062         call transpose2(Eug(1,1,i+2),e2t(1,1))
5063         call transpose2(Eug(1,1,i+3),e3t(1,1))
5064 !C Ematrix derivative in theta
5065         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5066         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5067         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5068
5069         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5070         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5071         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5072         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5073 !c       auxalary matrix of E i+1
5074         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5075         s1=scalar2(b1(1,iti2),auxvec(1))
5076 !c derivative of theta i+2 with constant i+3
5077         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5078 !c derivative of theta i+2 with constant i+2
5079         gs32=scalar2(b1(1,i+2),auxgvec(1))
5080 !c derivative of E matix in theta of i+1
5081         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5082
5083         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5084         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5085         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5086 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5087         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5088 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5089         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5090         s2=scalar2(b1(1,i+1),auxvec(1))
5091 !c derivative of theta i+1 with constant i+3
5092         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5093 !c derivative of theta i+2 with constant i+1
5094         gs21=scalar2(b1(1,i+1),auxgvec(1))
5095 !c derivative of theta i+3 with constant i+1
5096         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5097
5098         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5099         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5100 !c ae3gte2 is derivative over i+2
5101         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5102
5103         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5104         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5105 !c i+2
5106         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5107 !c i+3
5108         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5109
5110         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5111         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5112         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5113         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5114         if (shield_mode.eq.0) then
5115         fac_shield(i)=1.0
5116         fac_shield(j)=1.0
5117         endif
5118
5119         eello_turn4=eello_turn4-(s1+s2+s3) &
5120         *fac_shield(i)*fac_shield(j)       &
5121         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5122         eello_t4=-(s1+s2+s3)  &
5123           *fac_shield(i)*fac_shield(j)
5124 !C Now derivative over shield:
5125           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5126          (shield_mode.gt.0)) then
5127 !C          print *,i,j
5128
5129           do ilist=1,ishield_list(i)
5130            iresshield=shield_list(ilist,i)
5131            do k=1,3
5132            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5133 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5134            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5135                    rlocshield &
5136             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5137             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5138            +rlocshield
5139            enddo
5140           enddo
5141           do ilist=1,ishield_list(j)
5142            iresshield=shield_list(ilist,j)
5143            do k=1,3
5144 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5145            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5146            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5147                    rlocshield  &
5148            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5149            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5150                   +rlocshield
5151 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5152
5153            enddo
5154           enddo
5155           do k=1,3
5156             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5157                    grad_shield(k,i)*eello_t4/fac_shield(i)
5158             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5159                    grad_shield(k,j)*eello_t4/fac_shield(j)
5160             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5161                    grad_shield(k,i)*eello_t4/fac_shield(i)
5162             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5163                    grad_shield(k,j)*eello_t4/fac_shield(j)
5164 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5165            enddo
5166            endif
5167 #ifdef NEWCORR
5168         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5169                        -(gs13+gsE13+gsEE1)*wturn4&
5170        *fac_shield(i)*fac_shield(j)
5171         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5172                          -(gs23+gs21+gsEE2)*wturn4&
5173        *fac_shield(i)*fac_shield(j)
5174
5175         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5176                          -(gs32+gsE31+gsEE3)*wturn4&
5177        *fac_shield(i)*fac_shield(j)
5178
5179 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5180 !c     &   gs2
5181 #endif
5182         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5183            'eturn4',i,j,-(s1+s2+s3)
5184 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5185 !d     &    ' eello_turn4_num',8*eello_turn4_num
5186 ! Derivatives in gamma(i)
5187         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5188         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5189         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5190         s1=scalar2(b1(1,i+1),auxvec(1))
5191         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5192         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5193         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5194        *fac_shield(i)*fac_shield(j)  &
5195        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5196
5197 ! Derivatives in gamma(i+1)
5198         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5199         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5200         s2=scalar2(b1(1,iti1),auxvec(1))
5201         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5202         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5203         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5204         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5205        *fac_shield(i)*fac_shield(j)  &
5206        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5207
5208 ! Derivatives in gamma(i+2)
5209         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5210         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5211         s1=scalar2(b1(1,iti2),auxvec(1))
5212         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5213         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5214         s2=scalar2(b1(1,iti1),auxvec(1))
5215         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5216         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5217         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5218         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5219        *fac_shield(i)*fac_shield(j)  &
5220        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5221
5222 ! Cartesian derivatives
5223 ! Derivatives of this turn contributions in DC(i+2)
5224         if (j.lt.nres-1) then
5225           do l=1,3
5226             a_temp(1,1)=agg(l,1)
5227             a_temp(1,2)=agg(l,2)
5228             a_temp(2,1)=agg(l,3)
5229             a_temp(2,2)=agg(l,4)
5230             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5231             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5232             s1=scalar2(b1(1,iti2),auxvec(1))
5233             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5234             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5235             s2=scalar2(b1(1,iti1),auxvec(1))
5236             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5237             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5238             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5239             ggg(l)=-(s1+s2+s3)
5240             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5241        *fac_shield(i)*fac_shield(j)  &
5242        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5243
5244           enddo
5245         endif
5246 ! Remaining derivatives of this turn contribution
5247         do l=1,3
5248           a_temp(1,1)=aggi(l,1)
5249           a_temp(1,2)=aggi(l,2)
5250           a_temp(2,1)=aggi(l,3)
5251           a_temp(2,2)=aggi(l,4)
5252           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5253           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5254           s1=scalar2(b1(1,iti2),auxvec(1))
5255           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5256           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5257           s2=scalar2(b1(1,iti1),auxvec(1))
5258           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5259           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5260           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5261           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5262          *fac_shield(i)*fac_shield(j)  &
5263          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5264
5265
5266           a_temp(1,1)=aggi1(l,1)
5267           a_temp(1,2)=aggi1(l,2)
5268           a_temp(2,1)=aggi1(l,3)
5269           a_temp(2,2)=aggi1(l,4)
5270           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5271           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5272           s1=scalar2(b1(1,iti2),auxvec(1))
5273           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5274           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5275           s2=scalar2(b1(1,iti1),auxvec(1))
5276           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5277           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5278           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5279           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5280          *fac_shield(i)*fac_shield(j)  &
5281          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5282
5283
5284           a_temp(1,1)=aggj(l,1)
5285           a_temp(1,2)=aggj(l,2)
5286           a_temp(2,1)=aggj(l,3)
5287           a_temp(2,2)=aggj(l,4)
5288           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5289           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5290           s1=scalar2(b1(1,iti2),auxvec(1))
5291           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5292           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5293           s2=scalar2(b1(1,iti1),auxvec(1))
5294           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5295           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5296           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5297 !        if (j.lt.nres-1) then
5298           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5299          *fac_shield(i)*fac_shield(j)  &
5300          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5301 !        endif
5302
5303           a_temp(1,1)=aggj1(l,1)
5304           a_temp(1,2)=aggj1(l,2)
5305           a_temp(2,1)=aggj1(l,3)
5306           a_temp(2,2)=aggj1(l,4)
5307           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5308           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5309           s1=scalar2(b1(1,iti2),auxvec(1))
5310           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5311           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5312           s2=scalar2(b1(1,iti1),auxvec(1))
5313           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5314           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5315           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5316 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5317 !        if (j.lt.nres-1) then
5318 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5319           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5320          *fac_shield(i)*fac_shield(j)  &
5321          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5322 !            if (shield_mode.gt.0) then
5323 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5324 !            else
5325 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5326 !            endif
5327 !         endif
5328         enddo
5329          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5330           ssgradlipi*eello_t4/4.0d0*lipscale
5331          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5332           ssgradlipj*eello_t4/4.0d0*lipscale
5333          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5334           ssgradlipi*eello_t4/4.0d0*lipscale
5335          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5336           ssgradlipj*eello_t4/4.0d0*lipscale
5337
5338       return
5339       end subroutine eturn4
5340 !-----------------------------------------------------------------------------
5341       subroutine unormderiv(u,ugrad,unorm,ungrad)
5342 ! This subroutine computes the derivatives of a normalized vector u, given
5343 ! the derivatives computed without normalization conditions, ugrad. Returns
5344 ! ungrad.
5345 !      implicit none
5346       real(kind=8),dimension(3) :: u,vec
5347       real(kind=8),dimension(3,3) ::ugrad,ungrad
5348       real(kind=8) :: unorm      !,scalar
5349       integer :: i,j
5350 !      write (2,*) 'ugrad',ugrad
5351 !      write (2,*) 'u',u
5352       do i=1,3
5353         vec(i)=scalar(ugrad(1,i),u(1))
5354       enddo
5355 !      write (2,*) 'vec',vec
5356       do i=1,3
5357         do j=1,3
5358           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5359         enddo
5360       enddo
5361 !      write (2,*) 'ungrad',ungrad
5362       return
5363       end subroutine unormderiv
5364 !-----------------------------------------------------------------------------
5365       subroutine escp_soft_sphere(evdw2,evdw2_14)
5366 !
5367 ! This subroutine calculates the excluded-volume interaction energy between
5368 ! peptide-group centers and side chains and its gradient in virtual-bond and
5369 ! side-chain vectors.
5370 !
5371 !      implicit real*8 (a-h,o-z)
5372 !      include 'DIMENSIONS'
5373 !      include 'COMMON.GEO'
5374 !      include 'COMMON.VAR'
5375 !      include 'COMMON.LOCAL'
5376 !      include 'COMMON.CHAIN'
5377 !      include 'COMMON.DERIV'
5378 !      include 'COMMON.INTERACT'
5379 !      include 'COMMON.FFIELD'
5380 !      include 'COMMON.IOUNITS'
5381 !      include 'COMMON.CONTROL'
5382       real(kind=8),dimension(3) :: ggg
5383 !el local variables
5384       integer :: i,iint,j,k,iteli,itypj
5385       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5386                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5387
5388       evdw2=0.0D0
5389       evdw2_14=0.0d0
5390       r0_scp=4.5d0
5391 !d    print '(a)','Enter ESCP'
5392 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5393       do i=iatscp_s,iatscp_e
5394         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5395         iteli=itel(i)
5396         xi=0.5D0*(c(1,i)+c(1,i+1))
5397         yi=0.5D0*(c(2,i)+c(2,i+1))
5398         zi=0.5D0*(c(3,i)+c(3,i+1))
5399
5400         do iint=1,nscp_gr(i)
5401
5402         do j=iscpstart(i,iint),iscpend(i,iint)
5403           if (itype(j,1).eq.ntyp1) cycle
5404           itypj=iabs(itype(j,1))
5405 ! Uncomment following three lines for SC-p interactions
5406 !         xj=c(1,nres+j)-xi
5407 !         yj=c(2,nres+j)-yi
5408 !         zj=c(3,nres+j)-zi
5409 ! Uncomment following three lines for Ca-p interactions
5410           xj=c(1,j)-xi
5411           yj=c(2,j)-yi
5412           zj=c(3,j)-zi
5413           rij=xj*xj+yj*yj+zj*zj
5414           r0ij=r0_scp
5415           r0ijsq=r0ij*r0ij
5416           if (rij.lt.r0ijsq) then
5417             evdwij=0.25d0*(rij-r0ijsq)**2
5418             fac=rij-r0ijsq
5419           else
5420             evdwij=0.0d0
5421             fac=0.0d0
5422           endif
5423           evdw2=evdw2+evdwij
5424 !
5425 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5426 !
5427           ggg(1)=xj*fac
5428           ggg(2)=yj*fac
5429           ggg(3)=zj*fac
5430 !grad          if (j.lt.i) then
5431 !d          write (iout,*) 'j<i'
5432 ! Uncomment following three lines for SC-p interactions
5433 !           do k=1,3
5434 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5435 !           enddo
5436 !grad          else
5437 !d          write (iout,*) 'j>i'
5438 !grad            do k=1,3
5439 !grad              ggg(k)=-ggg(k)
5440 ! Uncomment following line for SC-p interactions
5441 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5442 !grad            enddo
5443 !grad          endif
5444 !grad          do k=1,3
5445 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5446 !grad          enddo
5447 !grad          kstart=min0(i+1,j)
5448 !grad          kend=max0(i-1,j-1)
5449 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5450 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5451 !grad          do k=kstart,kend
5452 !grad            do l=1,3
5453 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5454 !grad            enddo
5455 !grad          enddo
5456           do k=1,3
5457             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5458             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5459           enddo
5460         enddo
5461
5462         enddo ! iint
5463       enddo ! i
5464       return
5465       end subroutine escp_soft_sphere
5466 !-----------------------------------------------------------------------------
5467       subroutine escp(evdw2,evdw2_14)
5468 !
5469 ! This subroutine calculates the excluded-volume interaction energy between
5470 ! peptide-group centers and side chains and its gradient in virtual-bond and
5471 ! side-chain vectors.
5472 !
5473 !      implicit real*8 (a-h,o-z)
5474 !      include 'DIMENSIONS'
5475 !      include 'COMMON.GEO'
5476 !      include 'COMMON.VAR'
5477 !      include 'COMMON.LOCAL'
5478 !      include 'COMMON.CHAIN'
5479 !      include 'COMMON.DERIV'
5480 !      include 'COMMON.INTERACT'
5481 !      include 'COMMON.FFIELD'
5482 !      include 'COMMON.IOUNITS'
5483 !      include 'COMMON.CONTROL'
5484       real(kind=8),dimension(3) :: ggg
5485 !el local variables
5486       integer :: i,iint,j,k,iteli,itypj,subchap
5487       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5488                    e1,e2,evdwij,rij
5489       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5490                     dist_temp, dist_init
5491       integer xshift,yshift,zshift
5492
5493       evdw2=0.0D0
5494       evdw2_14=0.0d0
5495 !d    print '(a)','Enter ESCP'
5496 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5497       do i=iatscp_s,iatscp_e
5498         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5499         iteli=itel(i)
5500         xi=0.5D0*(c(1,i)+c(1,i+1))
5501         yi=0.5D0*(c(2,i)+c(2,i+1))
5502         zi=0.5D0*(c(3,i)+c(3,i+1))
5503           xi=mod(xi,boxxsize)
5504           if (xi.lt.0) xi=xi+boxxsize
5505           yi=mod(yi,boxysize)
5506           if (yi.lt.0) yi=yi+boxysize
5507           zi=mod(zi,boxzsize)
5508           if (zi.lt.0) zi=zi+boxzsize
5509
5510         do iint=1,nscp_gr(i)
5511
5512         do j=iscpstart(i,iint),iscpend(i,iint)
5513           itypj=iabs(itype(j,1))
5514           if (itypj.eq.ntyp1) cycle
5515 ! Uncomment following three lines for SC-p interactions
5516 !         xj=c(1,nres+j)-xi
5517 !         yj=c(2,nres+j)-yi
5518 !         zj=c(3,nres+j)-zi
5519 ! Uncomment following three lines for Ca-p interactions
5520 !          xj=c(1,j)-xi
5521 !          yj=c(2,j)-yi
5522 !          zj=c(3,j)-zi
5523           xj=c(1,j)
5524           yj=c(2,j)
5525           zj=c(3,j)
5526           xj=mod(xj,boxxsize)
5527           if (xj.lt.0) xj=xj+boxxsize
5528           yj=mod(yj,boxysize)
5529           if (yj.lt.0) yj=yj+boxysize
5530           zj=mod(zj,boxzsize)
5531           if (zj.lt.0) zj=zj+boxzsize
5532       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5533       xj_safe=xj
5534       yj_safe=yj
5535       zj_safe=zj
5536       subchap=0
5537       do xshift=-1,1
5538       do yshift=-1,1
5539       do zshift=-1,1
5540           xj=xj_safe+xshift*boxxsize
5541           yj=yj_safe+yshift*boxysize
5542           zj=zj_safe+zshift*boxzsize
5543           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5544           if(dist_temp.lt.dist_init) then
5545             dist_init=dist_temp
5546             xj_temp=xj
5547             yj_temp=yj
5548             zj_temp=zj
5549             subchap=1
5550           endif
5551        enddo
5552        enddo
5553        enddo
5554        if (subchap.eq.1) then
5555           xj=xj_temp-xi
5556           yj=yj_temp-yi
5557           zj=zj_temp-zi
5558        else
5559           xj=xj_safe-xi
5560           yj=yj_safe-yi
5561           zj=zj_safe-zi
5562        endif
5563
5564           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5565           rij=dsqrt(1.0d0/rrij)
5566             sss_ele_cut=sscale_ele(rij)
5567             sss_ele_grad=sscagrad_ele(rij)
5568 !            print *,sss_ele_cut,sss_ele_grad,&
5569 !            (rij),r_cut_ele,rlamb_ele
5570             if (sss_ele_cut.le.0.0) cycle
5571           fac=rrij**expon2
5572           e1=fac*fac*aad(itypj,iteli)
5573           e2=fac*bad(itypj,iteli)
5574           if (iabs(j-i) .le. 2) then
5575             e1=scal14*e1
5576             e2=scal14*e2
5577             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5578           endif
5579           evdwij=e1+e2
5580           evdw2=evdw2+evdwij*sss_ele_cut
5581 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5582 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5583           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5584              'evdw2',i,j,evdwij
5585 !
5586 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5587 !
5588           fac=-(evdwij+e1)*rrij*sss_ele_cut
5589           fac=fac+evdwij*sss_ele_grad/rij/expon
5590           ggg(1)=xj*fac
5591           ggg(2)=yj*fac
5592           ggg(3)=zj*fac
5593 !grad          if (j.lt.i) then
5594 !d          write (iout,*) 'j<i'
5595 ! Uncomment following three lines for SC-p interactions
5596 !           do k=1,3
5597 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5598 !           enddo
5599 !grad          else
5600 !d          write (iout,*) 'j>i'
5601 !grad            do k=1,3
5602 !grad              ggg(k)=-ggg(k)
5603 ! Uncomment following line for SC-p interactions
5604 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5605 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5606 !grad            enddo
5607 !grad          endif
5608 !grad          do k=1,3
5609 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5610 !grad          enddo
5611 !grad          kstart=min0(i+1,j)
5612 !grad          kend=max0(i-1,j-1)
5613 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5614 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5615 !grad          do k=kstart,kend
5616 !grad            do l=1,3
5617 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5618 !grad            enddo
5619 !grad          enddo
5620           do k=1,3
5621             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5622             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5623           enddo
5624         enddo
5625
5626         enddo ! iint
5627       enddo ! i
5628       do i=1,nct
5629         do j=1,3
5630           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5631           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5632           gradx_scp(j,i)=expon*gradx_scp(j,i)
5633         enddo
5634       enddo
5635 !******************************************************************************
5636 !
5637 !                              N O T E !!!
5638 !
5639 ! To save time the factor EXPON has been extracted from ALL components
5640 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5641 ! use!
5642 !
5643 !******************************************************************************
5644       return
5645       end subroutine escp
5646 !-----------------------------------------------------------------------------
5647       subroutine edis(ehpb)
5648 !
5649 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5650 !
5651 !      implicit real*8 (a-h,o-z)
5652 !      include 'DIMENSIONS'
5653 !      include 'COMMON.SBRIDGE'
5654 !      include 'COMMON.CHAIN'
5655 !      include 'COMMON.DERIV'
5656 !      include 'COMMON.VAR'
5657 !      include 'COMMON.INTERACT'
5658 !      include 'COMMON.IOUNITS'
5659       real(kind=8),dimension(3) :: ggg
5660 !el local variables
5661       integer :: i,j,ii,jj,iii,jjj,k
5662       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5663
5664       ehpb=0.0D0
5665 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5666 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5667       if (link_end.eq.0) return
5668       do i=link_start,link_end
5669 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5670 ! CA-CA distance used in regularization of structure.
5671         ii=ihpb(i)
5672         jj=jhpb(i)
5673 ! iii and jjj point to the residues for which the distance is assigned.
5674         if (ii.gt.nres) then
5675           iii=ii-nres
5676           jjj=jj-nres
5677         else
5678           iii=ii
5679           jjj=jj
5680         endif
5681 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5682 !     &    dhpb(i),dhpb1(i),forcon(i)
5683 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5684 !    distance and angle dependent SS bond potential.
5685 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5686 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5687         if (.not.dyn_ss .and. i.le.nss) then
5688 ! 15/02/13 CC dynamic SSbond - additional check
5689          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5690         iabs(itype(jjj,1)).eq.1) then
5691           call ssbond_ene(iii,jjj,eij)
5692           ehpb=ehpb+2*eij
5693 !d          write (iout,*) "eij",eij
5694          endif
5695         else if (ii.gt.nres .and. jj.gt.nres) then
5696 !c Restraints from contact prediction
5697           dd=dist(ii,jj)
5698           if (constr_dist.eq.11) then
5699             ehpb=ehpb+fordepth(i)**4.0d0 &
5700                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5701             fac=fordepth(i)**4.0d0 &
5702                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5703           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5704             ehpb,fordepth(i),dd
5705            else
5706           if (dhpb1(i).gt.0.0d0) then
5707             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5708             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5709 !c            write (iout,*) "beta nmr",
5710 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5711           else
5712             dd=dist(ii,jj)
5713             rdis=dd-dhpb(i)
5714 !C Get the force constant corresponding to this distance.
5715             waga=forcon(i)
5716 !C Calculate the contribution to energy.
5717             ehpb=ehpb+waga*rdis*rdis
5718 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5719 !C
5720 !C Evaluate gradient.
5721 !C
5722             fac=waga*rdis/dd
5723           endif
5724           endif
5725           do j=1,3
5726             ggg(j)=fac*(c(j,jj)-c(j,ii))
5727           enddo
5728           do j=1,3
5729             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5730             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5731           enddo
5732           do k=1,3
5733             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5734             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5735           enddo
5736         else
5737           dd=dist(ii,jj)
5738           if (constr_dist.eq.11) then
5739             ehpb=ehpb+fordepth(i)**4.0d0 &
5740                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5741             fac=fordepth(i)**4.0d0 &
5742                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5743           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5744          ehpb,fordepth(i),dd
5745            else
5746           if (dhpb1(i).gt.0.0d0) then
5747             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5748             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5749 !c            write (iout,*) "alph nmr",
5750 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5751           else
5752             rdis=dd-dhpb(i)
5753 !C Get the force constant corresponding to this distance.
5754             waga=forcon(i)
5755 !C Calculate the contribution to energy.
5756             ehpb=ehpb+waga*rdis*rdis
5757 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5758 !C
5759 !C Evaluate gradient.
5760 !C
5761             fac=waga*rdis/dd
5762           endif
5763           endif
5764
5765             do j=1,3
5766               ggg(j)=fac*(c(j,jj)-c(j,ii))
5767             enddo
5768 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5769 !C If this is a SC-SC distance, we need to calculate the contributions to the
5770 !C Cartesian gradient in the SC vectors (ghpbx).
5771           if (iii.lt.ii) then
5772           do j=1,3
5773             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5774             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5775           enddo
5776           endif
5777 !cgrad        do j=iii,jjj-1
5778 !cgrad          do k=1,3
5779 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5780 !cgrad          enddo
5781 !cgrad        enddo
5782           do k=1,3
5783             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5784             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5785           enddo
5786         endif
5787       enddo
5788       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5789
5790       return
5791       end subroutine edis
5792 !-----------------------------------------------------------------------------
5793       subroutine ssbond_ene(i,j,eij)
5794 !
5795 ! Calculate the distance and angle dependent SS-bond potential energy
5796 ! using a free-energy function derived based on RHF/6-31G** ab initio
5797 ! calculations of diethyl disulfide.
5798 !
5799 ! A. Liwo and U. Kozlowska, 11/24/03
5800 !
5801 !      implicit real*8 (a-h,o-z)
5802 !      include 'DIMENSIONS'
5803 !      include 'COMMON.SBRIDGE'
5804 !      include 'COMMON.CHAIN'
5805 !      include 'COMMON.DERIV'
5806 !      include 'COMMON.LOCAL'
5807 !      include 'COMMON.INTERACT'
5808 !      include 'COMMON.VAR'
5809 !      include 'COMMON.IOUNITS'
5810       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5811 !el local variables
5812       integer :: i,j,itypi,itypj,k
5813       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5814                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5815                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5816                    cosphi,ggk
5817
5818       itypi=iabs(itype(i,1))
5819       xi=c(1,nres+i)
5820       yi=c(2,nres+i)
5821       zi=c(3,nres+i)
5822       dxi=dc_norm(1,nres+i)
5823       dyi=dc_norm(2,nres+i)
5824       dzi=dc_norm(3,nres+i)
5825 !      dsci_inv=dsc_inv(itypi)
5826       dsci_inv=vbld_inv(nres+i)
5827       itypj=iabs(itype(j,1))
5828 !      dscj_inv=dsc_inv(itypj)
5829       dscj_inv=vbld_inv(nres+j)
5830       xj=c(1,nres+j)-xi
5831       yj=c(2,nres+j)-yi
5832       zj=c(3,nres+j)-zi
5833       dxj=dc_norm(1,nres+j)
5834       dyj=dc_norm(2,nres+j)
5835       dzj=dc_norm(3,nres+j)
5836       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5837       rij=dsqrt(rrij)
5838       erij(1)=xj*rij
5839       erij(2)=yj*rij
5840       erij(3)=zj*rij
5841       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5842       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5843       om12=dxi*dxj+dyi*dyj+dzi*dzj
5844       do k=1,3
5845         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5846         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5847       enddo
5848       rij=1.0d0/rij
5849       deltad=rij-d0cm
5850       deltat1=1.0d0-om1
5851       deltat2=1.0d0+om2
5852       deltat12=om2-om1+2.0d0
5853       cosphi=om12-om1*om2
5854       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5855         +akct*deltad*deltat12 &
5856         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5857 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5858 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5859 !     &  " deltat12",deltat12," eij",eij
5860       ed=2*akcm*deltad+akct*deltat12
5861       pom1=akct*deltad
5862       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5863       eom1=-2*akth*deltat1-pom1-om2*pom2
5864       eom2= 2*akth*deltat2+pom1-om1*pom2
5865       eom12=pom2
5866       do k=1,3
5867         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5868         ghpbx(k,i)=ghpbx(k,i)-ggk &
5869                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5870                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5871         ghpbx(k,j)=ghpbx(k,j)+ggk &
5872                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5873                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5874         ghpbc(k,i)=ghpbc(k,i)-ggk
5875         ghpbc(k,j)=ghpbc(k,j)+ggk
5876       enddo
5877 !
5878 ! Calculate the components of the gradient in DC and X
5879 !
5880 !grad      do k=i,j-1
5881 !grad        do l=1,3
5882 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5883 !grad        enddo
5884 !grad      enddo
5885       return
5886       end subroutine ssbond_ene
5887 !-----------------------------------------------------------------------------
5888       subroutine ebond(estr)
5889 !
5890 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5891 !
5892 !      implicit real*8 (a-h,o-z)
5893 !      include 'DIMENSIONS'
5894 !      include 'COMMON.LOCAL'
5895 !      include 'COMMON.GEO'
5896 !      include 'COMMON.INTERACT'
5897 !      include 'COMMON.DERIV'
5898 !      include 'COMMON.VAR'
5899 !      include 'COMMON.CHAIN'
5900 !      include 'COMMON.IOUNITS'
5901 !      include 'COMMON.NAMES'
5902 !      include 'COMMON.FFIELD'
5903 !      include 'COMMON.CONTROL'
5904 !      include 'COMMON.SETUP'
5905       real(kind=8),dimension(3) :: u,ud
5906 !el local variables
5907       integer :: i,j,iti,nbi,k
5908       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5909                    uprod1,uprod2
5910
5911       estr=0.0d0
5912       estr1=0.0d0
5913 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5914 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5915
5916       do i=ibondp_start,ibondp_end
5917         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5918         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5919 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5920 !C          do j=1,3
5921 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5922 !C            *dc(j,i-1)/vbld(i)
5923 !C          enddo
5924 !C          if (energy_dec) write(iout,*) &
5925 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5926         diff = vbld(i)-vbldpDUM
5927         else
5928         diff = vbld(i)-vbldp0
5929         endif
5930         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5931            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5932         estr=estr+diff*diff
5933         do j=1,3
5934           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5935         enddo
5936 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5937 !        endif
5938       enddo
5939       estr=0.5d0*AKP*estr+estr1
5940 !      print *,"estr_bb",estr,AKP
5941 !
5942 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5943 !
5944       do i=ibond_start,ibond_end
5945         iti=iabs(itype(i,1))
5946         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5947         if (iti.ne.10 .and. iti.ne.ntyp1) then
5948           nbi=nbondterm(iti)
5949           if (nbi.eq.1) then
5950             diff=vbld(i+nres)-vbldsc0(1,iti)
5951             if (energy_dec) write (iout,*) &
5952             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5953             AKSC(1,iti),AKSC(1,iti)*diff*diff
5954             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5955 !            print *,"estr_sc",estr
5956             do j=1,3
5957               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5958             enddo
5959           else
5960             do j=1,nbi
5961               diff=vbld(i+nres)-vbldsc0(j,iti)
5962               ud(j)=aksc(j,iti)*diff
5963               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5964             enddo
5965             uprod=u(1)
5966             do j=2,nbi
5967               uprod=uprod*u(j)
5968             enddo
5969             usum=0.0d0
5970             usumsqder=0.0d0
5971             do j=1,nbi
5972               uprod1=1.0d0
5973               uprod2=1.0d0
5974               do k=1,nbi
5975                 if (k.ne.j) then
5976                   uprod1=uprod1*u(k)
5977                   uprod2=uprod2*u(k)*u(k)
5978                 endif
5979               enddo
5980               usum=usum+uprod1
5981               usumsqder=usumsqder+ud(j)*uprod2
5982             enddo
5983             estr=estr+uprod/usum
5984 !            print *,"estr_sc",estr,i
5985
5986              if (energy_dec) write (iout,*) &
5987             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5988             AKSC(1,iti),uprod/usum
5989             do j=1,3
5990              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5991             enddo
5992           endif
5993         endif
5994       enddo
5995       return
5996       end subroutine ebond
5997 #ifdef CRYST_THETA
5998 !-----------------------------------------------------------------------------
5999       subroutine ebend(etheta)
6000 !
6001 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6002 ! angles gamma and its derivatives in consecutive thetas and gammas.
6003 !
6004       use comm_calcthet
6005 !      implicit real*8 (a-h,o-z)
6006 !      include 'DIMENSIONS'
6007 !      include 'COMMON.LOCAL'
6008 !      include 'COMMON.GEO'
6009 !      include 'COMMON.INTERACT'
6010 !      include 'COMMON.DERIV'
6011 !      include 'COMMON.VAR'
6012 !      include 'COMMON.CHAIN'
6013 !      include 'COMMON.IOUNITS'
6014 !      include 'COMMON.NAMES'
6015 !      include 'COMMON.FFIELD'
6016 !      include 'COMMON.CONTROL'
6017 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6018 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6019 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6020 !el      integer :: it
6021 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6022 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6023 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6024 !el local variables
6025       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6026        ichir21,ichir22
6027       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6028        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6029        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6030       real(kind=8),dimension(2) :: y,z
6031
6032       delta=0.02d0*pi
6033 !      time11=dexp(-2*time)
6034 !      time12=1.0d0
6035       etheta=0.0D0
6036 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6037       do i=ithet_start,ithet_end
6038         if (itype(i-1,1).eq.ntyp1) cycle
6039 ! Zero the energy function and its derivative at 0 or pi.
6040         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6041         it=itype(i-1,1)
6042         ichir1=isign(1,itype(i-2,1))
6043         ichir2=isign(1,itype(i,1))
6044          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6045          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6046          if (itype(i-1,1).eq.10) then
6047           itype1=isign(10,itype(i-2,1))
6048           ichir11=isign(1,itype(i-2,1))
6049           ichir12=isign(1,itype(i-2,1))
6050           itype2=isign(10,itype(i,1))
6051           ichir21=isign(1,itype(i,1))
6052           ichir22=isign(1,itype(i,1))
6053          endif
6054
6055         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6056 #ifdef OSF
6057           phii=phi(i)
6058           if (phii.ne.phii) phii=150.0
6059 #else
6060           phii=phi(i)
6061 #endif
6062           y(1)=dcos(phii)
6063           y(2)=dsin(phii)
6064         else
6065           y(1)=0.0D0
6066           y(2)=0.0D0
6067         endif
6068         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6069 #ifdef OSF
6070           phii1=phi(i+1)
6071           if (phii1.ne.phii1) phii1=150.0
6072           phii1=pinorm(phii1)
6073           z(1)=cos(phii1)
6074 #else
6075           phii1=phi(i+1)
6076           z(1)=dcos(phii1)
6077 #endif
6078           z(2)=dsin(phii1)
6079         else
6080           z(1)=0.0D0
6081           z(2)=0.0D0
6082         endif
6083 ! Calculate the "mean" value of theta from the part of the distribution
6084 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6085 ! In following comments this theta will be referred to as t_c.
6086         thet_pred_mean=0.0d0
6087         do k=1,2
6088             athetk=athet(k,it,ichir1,ichir2)
6089             bthetk=bthet(k,it,ichir1,ichir2)
6090           if (it.eq.10) then
6091              athetk=athet(k,itype1,ichir11,ichir12)
6092              bthetk=bthet(k,itype2,ichir21,ichir22)
6093           endif
6094          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6095         enddo
6096         dthett=thet_pred_mean*ssd
6097         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6098 ! Derivatives of the "mean" values in gamma1 and gamma2.
6099         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6100                +athet(2,it,ichir1,ichir2)*y(1))*ss
6101         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6102                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6103          if (it.eq.10) then
6104         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6105              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6106         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6107                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6108          endif
6109         if (theta(i).gt.pi-delta) then
6110           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6111                E_tc0)
6112           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6113           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6114           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6115               E_theta)
6116           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6117               E_tc)
6118         else if (theta(i).lt.delta) then
6119           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6120           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6121           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6122               E_theta)
6123           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6124           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6125               E_tc)
6126         else
6127           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6128               E_theta,E_tc)
6129         endif
6130         etheta=etheta+ethetai
6131         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6132             'ebend',i,ethetai
6133         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6134         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6135         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6136       enddo
6137 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6138
6139 ! Ufff.... We've done all this!!!
6140       return
6141       end subroutine ebend
6142 !-----------------------------------------------------------------------------
6143       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6144
6145       use comm_calcthet
6146 !      implicit real*8 (a-h,o-z)
6147 !      include 'DIMENSIONS'
6148 !      include 'COMMON.LOCAL'
6149 !      include 'COMMON.IOUNITS'
6150 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6151 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6152 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6153       integer :: i,j,k
6154       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6155 !el      integer :: it
6156 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6157 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6158 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6159 !el local variables
6160       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6161        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6162
6163 ! Calculate the contributions to both Gaussian lobes.
6164 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6165 ! The "polynomial part" of the "standard deviation" of this part of
6166 ! the distribution.
6167         sig=polthet(3,it)
6168         do j=2,0,-1
6169           sig=sig*thet_pred_mean+polthet(j,it)
6170         enddo
6171 ! Derivative of the "interior part" of the "standard deviation of the"
6172 ! gamma-dependent Gaussian lobe in t_c.
6173         sigtc=3*polthet(3,it)
6174         do j=2,1,-1
6175           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6176         enddo
6177         sigtc=sig*sigtc
6178 ! Set the parameters of both Gaussian lobes of the distribution.
6179 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6180         fac=sig*sig+sigc0(it)
6181         sigcsq=fac+fac
6182         sigc=1.0D0/sigcsq
6183 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6184         sigsqtc=-4.0D0*sigcsq*sigtc
6185 !       print *,i,sig,sigtc,sigsqtc
6186 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6187         sigtc=-sigtc/(fac*fac)
6188 ! Following variable is sigma(t_c)**(-2)
6189         sigcsq=sigcsq*sigcsq
6190         sig0i=sig0(it)
6191         sig0inv=1.0D0/sig0i**2
6192         delthec=thetai-thet_pred_mean
6193         delthe0=thetai-theta0i
6194         term1=-0.5D0*sigcsq*delthec*delthec
6195         term2=-0.5D0*sig0inv*delthe0*delthe0
6196 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6197 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6198 ! to the energy (this being the log of the distribution) at the end of energy
6199 ! term evaluation for this virtual-bond angle.
6200         if (term1.gt.term2) then
6201           termm=term1
6202           term2=dexp(term2-termm)
6203           term1=1.0d0
6204         else
6205           termm=term2
6206           term1=dexp(term1-termm)
6207           term2=1.0d0
6208         endif
6209 ! The ratio between the gamma-independent and gamma-dependent lobes of
6210 ! the distribution is a Gaussian function of thet_pred_mean too.
6211         diffak=gthet(2,it)-thet_pred_mean
6212         ratak=diffak/gthet(3,it)**2
6213         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6214 ! Let's differentiate it in thet_pred_mean NOW.
6215         aktc=ak*ratak
6216 ! Now put together the distribution terms to make complete distribution.
6217         termexp=term1+ak*term2
6218         termpre=sigc+ak*sig0i
6219 ! Contribution of the bending energy from this theta is just the -log of
6220 ! the sum of the contributions from the two lobes and the pre-exponential
6221 ! factor. Simple enough, isn't it?
6222         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6223 ! NOW the derivatives!!!
6224 ! 6/6/97 Take into account the deformation.
6225         E_theta=(delthec*sigcsq*term1 &
6226              +ak*delthe0*sig0inv*term2)/termexp
6227         E_tc=((sigtc+aktc*sig0i)/termpre &
6228             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6229              aktc*term2)/termexp)
6230       return
6231       end subroutine theteng
6232 #else
6233 !-----------------------------------------------------------------------------
6234       subroutine ebend(etheta)
6235 !
6236 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6237 ! angles gamma and its derivatives in consecutive thetas and gammas.
6238 ! ab initio-derived potentials from
6239 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6240 !
6241 !      implicit real*8 (a-h,o-z)
6242 !      include 'DIMENSIONS'
6243 !      include 'COMMON.LOCAL'
6244 !      include 'COMMON.GEO'
6245 !      include 'COMMON.INTERACT'
6246 !      include 'COMMON.DERIV'
6247 !      include 'COMMON.VAR'
6248 !      include 'COMMON.CHAIN'
6249 !      include 'COMMON.IOUNITS'
6250 !      include 'COMMON.NAMES'
6251 !      include 'COMMON.FFIELD'
6252 !      include 'COMMON.CONTROL'
6253       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6254       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6255       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6256       logical :: lprn=.false., lprn1=.false.
6257 !el local variables
6258       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6259       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6260       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6261 ! local variables for constrains
6262       real(kind=8) :: difi,thetiii
6263        integer itheta
6264 !      write(iout,*) "in ebend",ithet_start,ithet_end
6265       call flush(iout)
6266       etheta=0.0D0
6267       do i=ithet_start,ithet_end
6268         if (itype(i-1,1).eq.ntyp1) cycle
6269         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6270         if (iabs(itype(i+1,1)).eq.20) iblock=2
6271         if (iabs(itype(i+1,1)).ne.20) iblock=1
6272         dethetai=0.0d0
6273         dephii=0.0d0
6274         dephii1=0.0d0
6275         theti2=0.5d0*theta(i)
6276         ityp2=ithetyp((itype(i-1,1)))
6277         do k=1,nntheterm
6278           coskt(k)=dcos(k*theti2)
6279           sinkt(k)=dsin(k*theti2)
6280         enddo
6281         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6282 #ifdef OSF
6283           phii=phi(i)
6284           if (phii.ne.phii) phii=150.0
6285 #else
6286           phii=phi(i)
6287 #endif
6288           ityp1=ithetyp((itype(i-2,1)))
6289 ! propagation of chirality for glycine type
6290           do k=1,nsingle
6291             cosph1(k)=dcos(k*phii)
6292             sinph1(k)=dsin(k*phii)
6293           enddo
6294         else
6295           phii=0.0d0
6296           ityp1=ithetyp(itype(i-2,1))
6297           do k=1,nsingle
6298             cosph1(k)=0.0d0
6299             sinph1(k)=0.0d0
6300           enddo
6301         endif
6302         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6303 #ifdef OSF
6304           phii1=phi(i+1)
6305           if (phii1.ne.phii1) phii1=150.0
6306           phii1=pinorm(phii1)
6307 #else
6308           phii1=phi(i+1)
6309 #endif
6310           ityp3=ithetyp((itype(i,1)))
6311           do k=1,nsingle
6312             cosph2(k)=dcos(k*phii1)
6313             sinph2(k)=dsin(k*phii1)
6314           enddo
6315         else
6316           phii1=0.0d0
6317           ityp3=ithetyp(itype(i,1))
6318           do k=1,nsingle
6319             cosph2(k)=0.0d0
6320             sinph2(k)=0.0d0
6321           enddo
6322         endif
6323         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6324         do k=1,ndouble
6325           do l=1,k-1
6326             ccl=cosph1(l)*cosph2(k-l)
6327             ssl=sinph1(l)*sinph2(k-l)
6328             scl=sinph1(l)*cosph2(k-l)
6329             csl=cosph1(l)*sinph2(k-l)
6330             cosph1ph2(l,k)=ccl-ssl
6331             cosph1ph2(k,l)=ccl+ssl
6332             sinph1ph2(l,k)=scl+csl
6333             sinph1ph2(k,l)=scl-csl
6334           enddo
6335         enddo
6336         if (lprn) then
6337         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6338           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6339         write (iout,*) "coskt and sinkt"
6340         do k=1,nntheterm
6341           write (iout,*) k,coskt(k),sinkt(k)
6342         enddo
6343         endif
6344         do k=1,ntheterm
6345           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6346           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6347             *coskt(k)
6348           if (lprn) &
6349           write (iout,*) "k",k,&
6350            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6351            " ethetai",ethetai
6352         enddo
6353         if (lprn) then
6354         write (iout,*) "cosph and sinph"
6355         do k=1,nsingle
6356           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6357         enddo
6358         write (iout,*) "cosph1ph2 and sinph2ph2"
6359         do k=2,ndouble
6360           do l=1,k-1
6361             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6362                sinph1ph2(l,k),sinph1ph2(k,l)
6363           enddo
6364         enddo
6365         write(iout,*) "ethetai",ethetai
6366         endif
6367         do m=1,ntheterm2
6368           do k=1,nsingle
6369             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6370                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6371                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6372                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6373             ethetai=ethetai+sinkt(m)*aux
6374             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6375             dephii=dephii+k*sinkt(m)* &
6376                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6377                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6378             dephii1=dephii1+k*sinkt(m)* &
6379                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6380                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6381             if (lprn) &
6382             write (iout,*) "m",m," k",k," bbthet", &
6383                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6384                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6385                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6386                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6387           enddo
6388         enddo
6389         if (lprn) &
6390         write(iout,*) "ethetai",ethetai
6391         do m=1,ntheterm3
6392           do k=2,ndouble
6393             do l=1,k-1
6394               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6395                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6396                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6397                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6398               ethetai=ethetai+sinkt(m)*aux
6399               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6400               dephii=dephii+l*sinkt(m)* &
6401                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6402                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6403                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6404                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6405               dephii1=dephii1+(k-l)*sinkt(m)* &
6406                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6407                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6408                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6409                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6410               if (lprn) then
6411               write (iout,*) "m",m," k",k," l",l," ffthet",&
6412                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6413                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6414                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6415                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6416                   " ethetai",ethetai
6417               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6418                   cosph1ph2(k,l)*sinkt(m),&
6419                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6420               endif
6421             enddo
6422           enddo
6423         enddo
6424 10      continue
6425 !        lprn1=.true.
6426         if (lprn1) &
6427           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6428          i,theta(i)*rad2deg,phii*rad2deg,&
6429          phii1*rad2deg,ethetai
6430 !        lprn1=.false.
6431         etheta=etheta+ethetai
6432         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6433                                     'ebend',i,ethetai
6434         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6435         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6436         gloc(nphi+i-2,icg)=wang*dethetai
6437       enddo
6438 !-----------thete constrains
6439 !      if (tor_mode.ne.2) then
6440
6441       return
6442       end subroutine ebend
6443 #endif
6444 #ifdef CRYST_SC
6445 !-----------------------------------------------------------------------------
6446       subroutine esc(escloc)
6447 ! Calculate the local energy of a side chain and its derivatives in the
6448 ! corresponding virtual-bond valence angles THETA and the spherical angles
6449 ! ALPHA and OMEGA.
6450 !
6451       use comm_sccalc
6452 !      implicit real*8 (a-h,o-z)
6453 !      include 'DIMENSIONS'
6454 !      include 'COMMON.GEO'
6455 !      include 'COMMON.LOCAL'
6456 !      include 'COMMON.VAR'
6457 !      include 'COMMON.INTERACT'
6458 !      include 'COMMON.DERIV'
6459 !      include 'COMMON.CHAIN'
6460 !      include 'COMMON.IOUNITS'
6461 !      include 'COMMON.NAMES'
6462 !      include 'COMMON.FFIELD'
6463 !      include 'COMMON.CONTROL'
6464       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6465          ddersc0,ddummy,xtemp,temp
6466 !el      real(kind=8) :: time11,time12,time112,theti
6467       real(kind=8) :: escloc,delta
6468 !el      integer :: it,nlobit
6469 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6470 !el local variables
6471       integer :: i,k
6472       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6473        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6474       delta=0.02d0*pi
6475       escloc=0.0D0
6476 !     write (iout,'(a)') 'ESC'
6477       do i=loc_start,loc_end
6478         it=itype(i,1)
6479         if (it.eq.ntyp1) cycle
6480         if (it.eq.10) goto 1
6481         nlobit=nlob(iabs(it))
6482 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6483 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6484         theti=theta(i+1)-pipol
6485         x(1)=dtan(theti)
6486         x(2)=alph(i)
6487         x(3)=omeg(i)
6488
6489         if (x(2).gt.pi-delta) then
6490           xtemp(1)=x(1)
6491           xtemp(2)=pi-delta
6492           xtemp(3)=x(3)
6493           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6494           xtemp(2)=pi
6495           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6496           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6497               escloci,dersc(2))
6498           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6499               ddersc0(1),dersc(1))
6500           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6501               ddersc0(3),dersc(3))
6502           xtemp(2)=pi-delta
6503           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6504           xtemp(2)=pi
6505           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6506           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6507                   dersc0(2),esclocbi,dersc02)
6508           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6509                   dersc12,dersc01)
6510           call splinthet(x(2),0.5d0*delta,ss,ssd)
6511           dersc0(1)=dersc01
6512           dersc0(2)=dersc02
6513           dersc0(3)=0.0d0
6514           do k=1,3
6515             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6516           enddo
6517           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6518 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6519 !    &             esclocbi,ss,ssd
6520           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6521 !         escloci=esclocbi
6522 !         write (iout,*) escloci
6523         else if (x(2).lt.delta) then
6524           xtemp(1)=x(1)
6525           xtemp(2)=delta
6526           xtemp(3)=x(3)
6527           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6528           xtemp(2)=0.0d0
6529           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6530           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6531               escloci,dersc(2))
6532           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6533               ddersc0(1),dersc(1))
6534           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6535               ddersc0(3),dersc(3))
6536           xtemp(2)=delta
6537           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6538           xtemp(2)=0.0d0
6539           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6540           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6541                   dersc0(2),esclocbi,dersc02)
6542           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6543                   dersc12,dersc01)
6544           dersc0(1)=dersc01
6545           dersc0(2)=dersc02
6546           dersc0(3)=0.0d0
6547           call splinthet(x(2),0.5d0*delta,ss,ssd)
6548           do k=1,3
6549             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6550           enddo
6551           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6552 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6553 !    &             esclocbi,ss,ssd
6554           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6555 !         write (iout,*) escloci
6556         else
6557           call enesc(x,escloci,dersc,ddummy,.false.)
6558         endif
6559
6560         escloc=escloc+escloci
6561         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6562            'escloc',i,escloci
6563 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6564
6565         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6566          wscloc*dersc(1)
6567         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6568         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6569     1   continue
6570       enddo
6571       return
6572       end subroutine esc
6573 !-----------------------------------------------------------------------------
6574       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6575
6576       use comm_sccalc
6577 !      implicit real*8 (a-h,o-z)
6578 !      include 'DIMENSIONS'
6579 !      include 'COMMON.GEO'
6580 !      include 'COMMON.LOCAL'
6581 !      include 'COMMON.IOUNITS'
6582 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6583       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6584       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6585       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6586       real(kind=8) :: escloci
6587       logical :: mixed
6588 !el local variables
6589       integer :: j,iii,l,k !el,it,nlobit
6590       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6591 !el       time11,time12,time112
6592 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6593         escloc_i=0.0D0
6594         do j=1,3
6595           dersc(j)=0.0D0
6596           if (mixed) ddersc(j)=0.0d0
6597         enddo
6598         x3=x(3)
6599
6600 ! Because of periodicity of the dependence of the SC energy in omega we have
6601 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6602 ! To avoid underflows, first compute & store the exponents.
6603
6604         do iii=-1,1
6605
6606           x(3)=x3+iii*dwapi
6607
6608           do j=1,nlobit
6609             do k=1,3
6610               z(k)=x(k)-censc(k,j,it)
6611             enddo
6612             do k=1,3
6613               Axk=0.0D0
6614               do l=1,3
6615                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6616               enddo
6617               Ax(k,j,iii)=Axk
6618             enddo
6619             expfac=0.0D0
6620             do k=1,3
6621               expfac=expfac+Ax(k,j,iii)*z(k)
6622             enddo
6623             contr(j,iii)=expfac
6624           enddo ! j
6625
6626         enddo ! iii
6627
6628         x(3)=x3
6629 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6630 ! subsequent NaNs and INFs in energy calculation.
6631 ! Find the largest exponent
6632         emin=contr(1,-1)
6633         do iii=-1,1
6634           do j=1,nlobit
6635             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6636           enddo
6637         enddo
6638         emin=0.5D0*emin
6639 !d      print *,'it=',it,' emin=',emin
6640
6641 ! Compute the contribution to SC energy and derivatives
6642         do iii=-1,1
6643
6644           do j=1,nlobit
6645 #ifdef OSF
6646             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6647             if(adexp.ne.adexp) adexp=1.0
6648             expfac=dexp(adexp)
6649 #else
6650             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6651 #endif
6652 !d          print *,'j=',j,' expfac=',expfac
6653             escloc_i=escloc_i+expfac
6654             do k=1,3
6655               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6656             enddo
6657             if (mixed) then
6658               do k=1,3,2
6659                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6660                   +gaussc(k,2,j,it))*expfac
6661               enddo
6662             endif
6663           enddo
6664
6665         enddo ! iii
6666
6667         dersc(1)=dersc(1)/cos(theti)**2
6668         ddersc(1)=ddersc(1)/cos(theti)**2
6669         ddersc(3)=ddersc(3)
6670
6671         escloci=-(dlog(escloc_i)-emin)
6672         do j=1,3
6673           dersc(j)=dersc(j)/escloc_i
6674         enddo
6675         if (mixed) then
6676           do j=1,3,2
6677             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6678           enddo
6679         endif
6680       return
6681       end subroutine enesc
6682 !-----------------------------------------------------------------------------
6683       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6684
6685       use comm_sccalc
6686 !      implicit real*8 (a-h,o-z)
6687 !      include 'DIMENSIONS'
6688 !      include 'COMMON.GEO'
6689 !      include 'COMMON.LOCAL'
6690 !      include 'COMMON.IOUNITS'
6691 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6692       real(kind=8),dimension(3) :: x,z,dersc
6693       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6694       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6695       real(kind=8) :: escloci,dersc12,emin
6696       logical :: mixed
6697 !el local varables
6698       integer :: j,k,l !el,it,nlobit
6699       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6700
6701       escloc_i=0.0D0
6702
6703       do j=1,3
6704         dersc(j)=0.0D0
6705       enddo
6706
6707       do j=1,nlobit
6708         do k=1,2
6709           z(k)=x(k)-censc(k,j,it)
6710         enddo
6711         z(3)=dwapi
6712         do k=1,3
6713           Axk=0.0D0
6714           do l=1,3
6715             Axk=Axk+gaussc(l,k,j,it)*z(l)
6716           enddo
6717           Ax(k,j)=Axk
6718         enddo
6719         expfac=0.0D0
6720         do k=1,3
6721           expfac=expfac+Ax(k,j)*z(k)
6722         enddo
6723         contr(j)=expfac
6724       enddo ! j
6725
6726 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6727 ! subsequent NaNs and INFs in energy calculation.
6728 ! Find the largest exponent
6729       emin=contr(1)
6730       do j=1,nlobit
6731         if (emin.gt.contr(j)) emin=contr(j)
6732       enddo
6733       emin=0.5D0*emin
6734
6735 ! Compute the contribution to SC energy and derivatives
6736
6737       dersc12=0.0d0
6738       do j=1,nlobit
6739         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6740         escloc_i=escloc_i+expfac
6741         do k=1,2
6742           dersc(k)=dersc(k)+Ax(k,j)*expfac
6743         enddo
6744         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6745                   +gaussc(1,2,j,it))*expfac
6746         dersc(3)=0.0d0
6747       enddo
6748
6749       dersc(1)=dersc(1)/cos(theti)**2
6750       dersc12=dersc12/cos(theti)**2
6751       escloci=-(dlog(escloc_i)-emin)
6752       do j=1,2
6753         dersc(j)=dersc(j)/escloc_i
6754       enddo
6755       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6756       return
6757       end subroutine enesc_bound
6758 #else
6759 !-----------------------------------------------------------------------------
6760       subroutine esc(escloc)
6761 ! Calculate the local energy of a side chain and its derivatives in the
6762 ! corresponding virtual-bond valence angles THETA and the spherical angles
6763 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6764 ! added by Urszula Kozlowska. 07/11/2007
6765 !
6766       use comm_sccalc
6767 !      implicit real*8 (a-h,o-z)
6768 !      include 'DIMENSIONS'
6769 !      include 'COMMON.GEO'
6770 !      include 'COMMON.LOCAL'
6771 !      include 'COMMON.VAR'
6772 !      include 'COMMON.SCROT'
6773 !      include 'COMMON.INTERACT'
6774 !      include 'COMMON.DERIV'
6775 !      include 'COMMON.CHAIN'
6776 !      include 'COMMON.IOUNITS'
6777 !      include 'COMMON.NAMES'
6778 !      include 'COMMON.FFIELD'
6779 !      include 'COMMON.CONTROL'
6780 !      include 'COMMON.VECTORS'
6781       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6782       real(kind=8),dimension(65) :: x
6783       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6784          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6785       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6786       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6787          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6788 !el local variables
6789       integer :: i,j,k !el,it,nlobit
6790       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6791 !el      real(kind=8) :: time11,time12,time112,theti
6792 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6793       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6794                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6795                    sumene1x,sumene2x,sumene3x,sumene4x,&
6796                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6797                    cosfac2xx,sinfac2yy
6798 #ifdef DEBUG
6799       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6800                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6801                    de_dt_num
6802 #endif
6803 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6804
6805       delta=0.02d0*pi
6806       escloc=0.0D0
6807       do i=loc_start,loc_end
6808         if (itype(i,1).eq.ntyp1) cycle
6809         costtab(i+1) =dcos(theta(i+1))
6810         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6811         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6812         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6813         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6814         cosfac=dsqrt(cosfac2)
6815         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6816         sinfac=dsqrt(sinfac2)
6817         it=iabs(itype(i,1))
6818         if (it.eq.10) goto 1
6819 !
6820 !  Compute the axes of tghe local cartesian coordinates system; store in
6821 !   x_prime, y_prime and z_prime
6822 !
6823         do j=1,3
6824           x_prime(j) = 0.00
6825           y_prime(j) = 0.00
6826           z_prime(j) = 0.00
6827         enddo
6828 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6829 !     &   dc_norm(3,i+nres)
6830         do j = 1,3
6831           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6832           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6833         enddo
6834         do j = 1,3
6835           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6836         enddo
6837 !       write (2,*) "i",i
6838 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6839 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6840 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6841 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6842 !      & " xy",scalar(x_prime(1),y_prime(1)),
6843 !      & " xz",scalar(x_prime(1),z_prime(1)),
6844 !      & " yy",scalar(y_prime(1),y_prime(1)),
6845 !      & " yz",scalar(y_prime(1),z_prime(1)),
6846 !      & " zz",scalar(z_prime(1),z_prime(1))
6847 !
6848 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6849 ! to local coordinate system. Store in xx, yy, zz.
6850 !
6851         xx=0.0d0
6852         yy=0.0d0
6853         zz=0.0d0
6854         do j = 1,3
6855           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6856           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6857           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6858         enddo
6859
6860         xxtab(i)=xx
6861         yytab(i)=yy
6862         zztab(i)=zz
6863 !
6864 ! Compute the energy of the ith side cbain
6865 !
6866 !        write (2,*) "xx",xx," yy",yy," zz",zz
6867         it=iabs(itype(i,1))
6868         do j = 1,65
6869           x(j) = sc_parmin(j,it)
6870         enddo
6871 #ifdef CHECK_COORD
6872 !c diagnostics - remove later
6873         xx1 = dcos(alph(2))
6874         yy1 = dsin(alph(2))*dcos(omeg(2))
6875         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6876         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6877           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6878           xx1,yy1,zz1
6879 !,"  --- ", xx_w,yy_w,zz_w
6880 ! end diagnostics
6881 #endif
6882         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6883          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6884          + x(10)*yy*zz
6885         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6886          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6887          + x(20)*yy*zz
6888         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6889          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6890          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6891          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6892          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6893          +x(40)*xx*yy*zz
6894         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6895          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6896          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6897          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6898          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6899          +x(60)*xx*yy*zz
6900         dsc_i   = 0.743d0+x(61)
6901         dp2_i   = 1.9d0+x(62)
6902         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6903                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6904         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6905                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6906         s1=(1+x(63))/(0.1d0 + dscp1)
6907         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6908         s2=(1+x(65))/(0.1d0 + dscp2)
6909         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6910         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6911       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6912 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6913 !     &   sumene4,
6914 !     &   dscp1,dscp2,sumene
6915 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6916         escloc = escloc + sumene
6917 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6918 !     & ,zz,xx,yy
6919 !#define DEBUG
6920 #ifdef DEBUG
6921 !
6922 ! This section to check the numerical derivatives of the energy of ith side
6923 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6924 ! #define DEBUG in the code to turn it on.
6925 !
6926         write (2,*) "sumene               =",sumene
6927         aincr=1.0d-7
6928         xxsave=xx
6929         xx=xx+aincr
6930         write (2,*) xx,yy,zz
6931         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6932         de_dxx_num=(sumenep-sumene)/aincr
6933         xx=xxsave
6934         write (2,*) "xx+ sumene from enesc=",sumenep
6935         yysave=yy
6936         yy=yy+aincr
6937         write (2,*) xx,yy,zz
6938         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6939         de_dyy_num=(sumenep-sumene)/aincr
6940         yy=yysave
6941         write (2,*) "yy+ sumene from enesc=",sumenep
6942         zzsave=zz
6943         zz=zz+aincr
6944         write (2,*) xx,yy,zz
6945         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6946         de_dzz_num=(sumenep-sumene)/aincr
6947         zz=zzsave
6948         write (2,*) "zz+ sumene from enesc=",sumenep
6949         costsave=cost2tab(i+1)
6950         sintsave=sint2tab(i+1)
6951         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6952         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6953         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6954         de_dt_num=(sumenep-sumene)/aincr
6955         write (2,*) " t+ sumene from enesc=",sumenep
6956         cost2tab(i+1)=costsave
6957         sint2tab(i+1)=sintsave
6958 ! End of diagnostics section.
6959 #endif
6960 !
6961 ! Compute the gradient of esc
6962 !
6963 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6964         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6965         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6966         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6967         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6968         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6969         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6970         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6971         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6972         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6973            *(pom_s1/dscp1+pom_s16*dscp1**4)
6974         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6975            *(pom_s2/dscp2+pom_s26*dscp2**4)
6976         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6977         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6978         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6979         +x(40)*yy*zz
6980         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6981         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6982         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6983         +x(60)*yy*zz
6984         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6985               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6986               +(pom1+pom2)*pom_dx
6987 #ifdef DEBUG
6988         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6989 #endif
6990 !
6991         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6992         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6993         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6994         +x(40)*xx*zz
6995         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6996         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6997         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6998         +x(59)*zz**2 +x(60)*xx*zz
6999         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7000               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7001               +(pom1-pom2)*pom_dy
7002 #ifdef DEBUG
7003         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7004 #endif
7005 !
7006         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7007         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7008         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7009         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7010         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7011         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7012         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7013         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7014 #ifdef DEBUG
7015         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7016 #endif
7017 !
7018         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7019         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7020         +pom1*pom_dt1+pom2*pom_dt2
7021 #ifdef DEBUG
7022         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7023 #endif
7024 !
7025 !
7026        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7027        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7028        cosfac2xx=cosfac2*xx
7029        sinfac2yy=sinfac2*yy
7030        do k = 1,3
7031          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7032             vbld_inv(i+1)
7033          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7034             vbld_inv(i)
7035          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7036          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7037 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7038 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7039 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7040 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7041          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7042          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7043          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7044          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7045          dZZ_Ci1(k)=0.0d0
7046          dZZ_Ci(k)=0.0d0
7047          do j=1,3
7048            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7049            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7050            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7051            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7052          enddo
7053
7054          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7055          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7056          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7057          (z_prime(k)-zz*dC_norm(k,i+nres))
7058 !
7059          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7060          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7061        enddo
7062
7063        do k=1,3
7064          dXX_Ctab(k,i)=dXX_Ci(k)
7065          dXX_C1tab(k,i)=dXX_Ci1(k)
7066          dYY_Ctab(k,i)=dYY_Ci(k)
7067          dYY_C1tab(k,i)=dYY_Ci1(k)
7068          dZZ_Ctab(k,i)=dZZ_Ci(k)
7069          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7070          dXX_XYZtab(k,i)=dXX_XYZ(k)
7071          dYY_XYZtab(k,i)=dYY_XYZ(k)
7072          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7073        enddo
7074
7075        do k = 1,3
7076 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7077 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7078 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7079 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7080 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7081 !     &    dt_dci(k)
7082 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7083 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7084          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7085           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7086          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7087           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7088          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7089           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7090        enddo
7091 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7092 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7093
7094 ! to check gradient call subroutine check_grad
7095
7096     1 continue
7097       enddo
7098       return
7099       end subroutine esc
7100 !-----------------------------------------------------------------------------
7101       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7102 !      implicit none
7103       real(kind=8),dimension(65) :: x
7104       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7105         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7106
7107       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7108         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7109         + x(10)*yy*zz
7110       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7111         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7112         + x(20)*yy*zz
7113       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7114         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7115         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7116         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7117         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7118         +x(40)*xx*yy*zz
7119       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7120         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7121         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7122         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7123         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7124         +x(60)*xx*yy*zz
7125       dsc_i   = 0.743d0+x(61)
7126       dp2_i   = 1.9d0+x(62)
7127       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7128                 *(xx*cost2+yy*sint2))
7129       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7130                 *(xx*cost2-yy*sint2))
7131       s1=(1+x(63))/(0.1d0 + dscp1)
7132       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7133       s2=(1+x(65))/(0.1d0 + dscp2)
7134       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7135       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7136        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7137       enesc=sumene
7138       return
7139       end function enesc
7140 #endif
7141 !-----------------------------------------------------------------------------
7142       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7143 !
7144 ! This procedure calculates two-body contact function g(rij) and its derivative:
7145 !
7146 !           eps0ij                                     !       x < -1
7147 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7148 !            0                                         !       x > 1
7149 !
7150 ! where x=(rij-r0ij)/delta
7151 !
7152 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7153 !
7154 !      implicit none
7155       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7156       real(kind=8) :: x,x2,x4,delta
7157 !     delta=0.02D0*r0ij
7158 !      delta=0.2D0*r0ij
7159       x=(rij-r0ij)/delta
7160       if (x.lt.-1.0D0) then
7161         fcont=eps0ij
7162         fprimcont=0.0D0
7163       else if (x.le.1.0D0) then
7164         x2=x*x
7165         x4=x2*x2
7166         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7167         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7168       else
7169         fcont=0.0D0
7170         fprimcont=0.0D0
7171       endif
7172       return
7173       end subroutine gcont
7174 !-----------------------------------------------------------------------------
7175       subroutine splinthet(theti,delta,ss,ssder)
7176 !      implicit real*8 (a-h,o-z)
7177 !      include 'DIMENSIONS'
7178 !      include 'COMMON.VAR'
7179 !      include 'COMMON.GEO'
7180       real(kind=8) :: theti,delta,ss,ssder
7181       real(kind=8) :: thetup,thetlow
7182       thetup=pi-delta
7183       thetlow=delta
7184       if (theti.gt.pipol) then
7185         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7186       else
7187         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7188         ssder=-ssder
7189       endif
7190       return
7191       end subroutine splinthet
7192 !-----------------------------------------------------------------------------
7193       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7194 !      implicit none
7195       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7196       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7197       a1=fprim0*delta/(f1-f0)
7198       a2=3.0d0-2.0d0*a1
7199       a3=a1-2.0d0
7200       ksi=(x-x0)/delta
7201       ksi2=ksi*ksi
7202       ksi3=ksi2*ksi
7203       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7204       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7205       return
7206       end subroutine spline1
7207 !-----------------------------------------------------------------------------
7208       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7209 !      implicit none
7210       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7211       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7212       ksi=(x-x0)/delta
7213       ksi2=ksi*ksi
7214       ksi3=ksi2*ksi
7215       a1=fprim0x*delta
7216       a2=3*(f1x-f0x)-2*fprim0x*delta
7217       a3=fprim0x*delta-2*(f1x-f0x)
7218       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7219       return
7220       end subroutine spline2
7221 !-----------------------------------------------------------------------------
7222 #ifdef CRYST_TOR
7223 !-----------------------------------------------------------------------------
7224       subroutine etor(etors,edihcnstr)
7225 !      implicit real*8 (a-h,o-z)
7226 !      include 'DIMENSIONS'
7227 !      include 'COMMON.VAR'
7228 !      include 'COMMON.GEO'
7229 !      include 'COMMON.LOCAL'
7230 !      include 'COMMON.TORSION'
7231 !      include 'COMMON.INTERACT'
7232 !      include 'COMMON.DERIV'
7233 !      include 'COMMON.CHAIN'
7234 !      include 'COMMON.NAMES'
7235 !      include 'COMMON.IOUNITS'
7236 !      include 'COMMON.FFIELD'
7237 !      include 'COMMON.TORCNSTR'
7238 !      include 'COMMON.CONTROL'
7239       real(kind=8) :: etors,edihcnstr
7240       logical :: lprn
7241 !el local variables
7242       integer :: i,j,
7243       real(kind=8) :: phii,fac,etors_ii
7244
7245 ! Set lprn=.true. for debugging
7246       lprn=.false.
7247 !      lprn=.true.
7248       etors=0.0D0
7249       do i=iphi_start,iphi_end
7250       etors_ii=0.0D0
7251         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7252             .or. itype(i,1).eq.ntyp1) cycle
7253         itori=itortyp(itype(i-2,1))
7254         itori1=itortyp(itype(i-1,1))
7255         phii=phi(i)
7256         gloci=0.0D0
7257 ! Proline-Proline pair is a special case...
7258         if (itori.eq.3 .and. itori1.eq.3) then
7259           if (phii.gt.-dwapi3) then
7260             cosphi=dcos(3*phii)
7261             fac=1.0D0/(1.0D0-cosphi)
7262             etorsi=v1(1,3,3)*fac
7263             etorsi=etorsi+etorsi
7264             etors=etors+etorsi-v1(1,3,3)
7265             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7266             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7267           endif
7268           do j=1,3
7269             v1ij=v1(j+1,itori,itori1)
7270             v2ij=v2(j+1,itori,itori1)
7271             cosphi=dcos(j*phii)
7272             sinphi=dsin(j*phii)
7273             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7274             if (energy_dec) etors_ii=etors_ii+ &
7275                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7276             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7277           enddo
7278         else
7279           do j=1,nterm_old
7280             v1ij=v1(j,itori,itori1)
7281             v2ij=v2(j,itori,itori1)
7282             cosphi=dcos(j*phii)
7283             sinphi=dsin(j*phii)
7284             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7285             if (energy_dec) etors_ii=etors_ii+ &
7286                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7287             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7288           enddo
7289         endif
7290         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7291              'etor',i,etors_ii
7292         if (lprn) &
7293         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7294         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7295         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7296         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7297 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7298       enddo
7299 ! 6/20/98 - dihedral angle constraints
7300       edihcnstr=0.0d0
7301       do i=1,ndih_constr
7302         itori=idih_constr(i)
7303         phii=phi(itori)
7304         difi=phii-phi0(i)
7305         if (difi.gt.drange(i)) then
7306           difi=difi-drange(i)
7307           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7308           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7309         else if (difi.lt.-drange(i)) then
7310           difi=difi+drange(i)
7311           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7312           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7313         endif
7314 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7315 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7316       enddo
7317 !      write (iout,*) 'edihcnstr',edihcnstr
7318       return
7319       end subroutine etor
7320 !-----------------------------------------------------------------------------
7321       subroutine etor_d(etors_d)
7322       real(kind=8) :: etors_d
7323       etors_d=0.0d0
7324       return
7325       end subroutine etor_d
7326 #else
7327 !-----------------------------------------------------------------------------
7328       subroutine etor(etors)
7329 !      implicit real*8 (a-h,o-z)
7330 !      include 'DIMENSIONS'
7331 !      include 'COMMON.VAR'
7332 !      include 'COMMON.GEO'
7333 !      include 'COMMON.LOCAL'
7334 !      include 'COMMON.TORSION'
7335 !      include 'COMMON.INTERACT'
7336 !      include 'COMMON.DERIV'
7337 !      include 'COMMON.CHAIN'
7338 !      include 'COMMON.NAMES'
7339 !      include 'COMMON.IOUNITS'
7340 !      include 'COMMON.FFIELD'
7341 !      include 'COMMON.TORCNSTR'
7342 !      include 'COMMON.CONTROL'
7343       real(kind=8) :: etors,edihcnstr
7344       logical :: lprn
7345 !el local variables
7346       integer :: i,j,iblock,itori,itori1
7347       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7348                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7349 ! Set lprn=.true. for debugging
7350       lprn=.false.
7351 !     lprn=.true.
7352       etors=0.0D0
7353       do i=iphi_start,iphi_end
7354         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7355              .or. itype(i-3,1).eq.ntyp1 &
7356              .or. itype(i,1).eq.ntyp1) cycle
7357         etors_ii=0.0D0
7358          if (iabs(itype(i,1)).eq.20) then
7359          iblock=2
7360          else
7361          iblock=1
7362          endif
7363         itori=itortyp(itype(i-2,1))
7364         itori1=itortyp(itype(i-1,1))
7365         phii=phi(i)
7366         gloci=0.0D0
7367 ! Regular cosine and sine terms
7368         do j=1,nterm(itori,itori1,iblock)
7369           v1ij=v1(j,itori,itori1,iblock)
7370           v2ij=v2(j,itori,itori1,iblock)
7371           cosphi=dcos(j*phii)
7372           sinphi=dsin(j*phii)
7373           etors=etors+v1ij*cosphi+v2ij*sinphi
7374           if (energy_dec) etors_ii=etors_ii+ &
7375                      v1ij*cosphi+v2ij*sinphi
7376           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7377         enddo
7378 ! Lorentz terms
7379 !                         v1
7380 !  E = SUM ----------------------------------- - v1
7381 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7382 !
7383         cosphi=dcos(0.5d0*phii)
7384         sinphi=dsin(0.5d0*phii)
7385         do j=1,nlor(itori,itori1,iblock)
7386           vl1ij=vlor1(j,itori,itori1)
7387           vl2ij=vlor2(j,itori,itori1)
7388           vl3ij=vlor3(j,itori,itori1)
7389           pom=vl2ij*cosphi+vl3ij*sinphi
7390           pom1=1.0d0/(pom*pom+1.0d0)
7391           etors=etors+vl1ij*pom1
7392           if (energy_dec) etors_ii=etors_ii+ &
7393                      vl1ij*pom1
7394           pom=-pom*pom1*pom1
7395           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7396         enddo
7397 ! Subtract the constant term
7398         etors=etors-v0(itori,itori1,iblock)
7399           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7400                'etor',i,etors_ii-v0(itori,itori1,iblock)
7401         if (lprn) &
7402         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7403         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7404         (v1(j,itori,itori1,iblock),j=1,6),&
7405         (v2(j,itori,itori1,iblock),j=1,6)
7406         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7407 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7408       enddo
7409 ! 6/20/98 - dihedral angle constraints
7410       return
7411       end subroutine etor
7412 !C The rigorous attempt to derive energy function
7413 !-------------------------------------------------------------------------------------------
7414       subroutine etor_kcc(etors)
7415       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7416       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7417        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7418        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7419        gradvalst2,etori
7420       logical lprn
7421       integer :: i,j,itori,itori1,nval,k,l
7422
7423       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7424       etors=0.0D0
7425       do i=iphi_start,iphi_end
7426 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7427 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7428 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7429 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7430         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7431            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7432         itori=itortyp(itype(i-2,1))
7433         itori1=itortyp(itype(i-1,1))
7434         phii=phi(i)
7435         glocig=0.0D0
7436         glocit1=0.0d0
7437         glocit2=0.0d0
7438 !C to avoid multiple devision by 2
7439 !c        theti22=0.5d0*theta(i)
7440 !C theta 12 is the theta_1 /2
7441 !C theta 22 is theta_2 /2
7442 !c        theti12=0.5d0*theta(i-1)
7443 !C and appropriate sinus function
7444         sinthet1=dsin(theta(i-1))
7445         sinthet2=dsin(theta(i))
7446         costhet1=dcos(theta(i-1))
7447         costhet2=dcos(theta(i))
7448 !C to speed up lets store its mutliplication
7449         sint1t2=sinthet2*sinthet1
7450         sint1t2n=1.0d0
7451 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7452 !C +d_n*sin(n*gamma)) *
7453 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7454 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7455         nval=nterm_kcc_Tb(itori,itori1)
7456         c1(0)=0.0d0
7457         c2(0)=0.0d0
7458         c1(1)=1.0d0
7459         c2(1)=1.0d0
7460         do j=2,nval
7461           c1(j)=c1(j-1)*costhet1
7462           c2(j)=c2(j-1)*costhet2
7463         enddo
7464         etori=0.0d0
7465
7466        do j=1,nterm_kcc(itori,itori1)
7467           cosphi=dcos(j*phii)
7468           sinphi=dsin(j*phii)
7469           sint1t2n1=sint1t2n
7470           sint1t2n=sint1t2n*sint1t2
7471           sumvalc=0.0d0
7472           gradvalct1=0.0d0
7473           gradvalct2=0.0d0
7474           do k=1,nval
7475             do l=1,nval
7476               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7477               gradvalct1=gradvalct1+ &
7478                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7479               gradvalct2=gradvalct2+ &
7480                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7481             enddo
7482           enddo
7483           gradvalct1=-gradvalct1*sinthet1
7484           gradvalct2=-gradvalct2*sinthet2
7485           sumvals=0.0d0
7486           gradvalst1=0.0d0
7487           gradvalst2=0.0d0
7488           do k=1,nval
7489             do l=1,nval
7490               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7491               gradvalst1=gradvalst1+ &
7492                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7493               gradvalst2=gradvalst2+ &
7494                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7495             enddo
7496           enddo
7497           gradvalst1=-gradvalst1*sinthet1
7498           gradvalst2=-gradvalst2*sinthet2
7499           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7500           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7501 !C glocig is the gradient local i site in gamma
7502           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7503 !C now gradient over theta_1
7504          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7505         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7506          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7507         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7508         enddo ! j
7509         etors=etors+etori
7510         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7511 !C derivative over theta1
7512         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7513 !C now derivative over theta2
7514         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7515         if (lprn) then
7516          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7517             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7518           write (iout,*) "c1",(c1(k),k=0,nval), &
7519          " c2",(c2(k),k=0,nval)
7520         endif
7521       enddo
7522       return
7523        end  subroutine etor_kcc
7524 !------------------------------------------------------------------------------
7525
7526         subroutine etor_constr(edihcnstr)
7527       real(kind=8) :: etors,edihcnstr
7528       logical :: lprn
7529 !el local variables
7530       integer :: i,j,iblock,itori,itori1
7531       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7532                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7533                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7534
7535       if (raw_psipred) then
7536         do i=idihconstr_start,idihconstr_end
7537           itori=idih_constr(i)
7538           phii=phi(itori)
7539           gaudih_i=vpsipred(1,i)
7540           gauder_i=0.0d0
7541           do j=1,2
7542             s = sdihed(j,i)
7543             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7544             dexpcos_i=dexp(-cos_i*cos_i)
7545             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7546           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7547                  *cos_i*dexpcos_i/s**2
7548           enddo
7549           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7550           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7551           if (energy_dec) &
7552           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7553           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7554           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7555           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7556           -wdihc*dlog(gaudih_i)
7557         enddo
7558       else
7559
7560       do i=idihconstr_start,idihconstr_end
7561         itori=idih_constr(i)
7562         phii=phi(itori)
7563         difi=pinorm(phii-phi0(i))
7564         if (difi.gt.drange(i)) then
7565           difi=difi-drange(i)
7566           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7567           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7568         else if (difi.lt.-drange(i)) then
7569           difi=difi+drange(i)
7570           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7571           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7572         else
7573           difi=0.0
7574         endif
7575       enddo
7576
7577       endif
7578
7579       return
7580
7581       end subroutine etor_constr
7582 !-----------------------------------------------------------------------------
7583       subroutine etor_d(etors_d)
7584 ! 6/23/01 Compute double torsional energy
7585 !      implicit real*8 (a-h,o-z)
7586 !      include 'DIMENSIONS'
7587 !      include 'COMMON.VAR'
7588 !      include 'COMMON.GEO'
7589 !      include 'COMMON.LOCAL'
7590 !      include 'COMMON.TORSION'
7591 !      include 'COMMON.INTERACT'
7592 !      include 'COMMON.DERIV'
7593 !      include 'COMMON.CHAIN'
7594 !      include 'COMMON.NAMES'
7595 !      include 'COMMON.IOUNITS'
7596 !      include 'COMMON.FFIELD'
7597 !      include 'COMMON.TORCNSTR'
7598       real(kind=8) :: etors_d,etors_d_ii
7599       logical :: lprn
7600 !el local variables
7601       integer :: i,j,k,l,itori,itori1,itori2,iblock
7602       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7603                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7604                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7605                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7606 ! Set lprn=.true. for debugging
7607       lprn=.false.
7608 !     lprn=.true.
7609       etors_d=0.0D0
7610 !      write(iout,*) "a tu??"
7611       do i=iphid_start,iphid_end
7612         etors_d_ii=0.0D0
7613         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7614             .or. itype(i-3,1).eq.ntyp1 &
7615             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7616         itori=itortyp(itype(i-2,1))
7617         itori1=itortyp(itype(i-1,1))
7618         itori2=itortyp(itype(i,1))
7619         phii=phi(i)
7620         phii1=phi(i+1)
7621         gloci1=0.0D0
7622         gloci2=0.0D0
7623         iblock=1
7624         if (iabs(itype(i+1,1)).eq.20) iblock=2
7625
7626 ! Regular cosine and sine terms
7627         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7628           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7629           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7630           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7631           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7632           cosphi1=dcos(j*phii)
7633           sinphi1=dsin(j*phii)
7634           cosphi2=dcos(j*phii1)
7635           sinphi2=dsin(j*phii1)
7636           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7637            v2cij*cosphi2+v2sij*sinphi2
7638           if (energy_dec) etors_d_ii=etors_d_ii+ &
7639            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7640           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7641           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7642         enddo
7643         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7644           do l=1,k-1
7645             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7646             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7647             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7648             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7649             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7650             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7651             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7652             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7653             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7654               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7655             if (energy_dec) etors_d_ii=etors_d_ii+ &
7656               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7657               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7658             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7659               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7660             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7661               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7662           enddo
7663         enddo
7664         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7665                             'etor_d',i,etors_d_ii
7666         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7667         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7668       enddo
7669       return
7670       end subroutine etor_d
7671 #endif
7672
7673       subroutine ebend_kcc(etheta)
7674       logical lprn
7675       double precision thybt1(maxang_kcc),etheta
7676       integer :: i,iti,j,ihelp
7677       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7678 !C Set lprn=.true. for debugging
7679       lprn=energy_dec
7680 !c     lprn=.true.
7681 !C      print *,"wchodze kcc"
7682       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7683       etheta=0.0D0
7684       do i=ithet_start,ithet_end
7685 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7686         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7687        .or.itype(i,1).eq.ntyp1) cycle
7688         iti=iabs(itortyp(itype(i-1,1)))
7689         sinthet=dsin(theta(i))
7690         costhet=dcos(theta(i))
7691         do j=1,nbend_kcc_Tb(iti)
7692           thybt1(j)=v1bend_chyb(j,iti)
7693         enddo
7694         sumth1thyb=v1bend_chyb(0,iti)+ &
7695          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7696         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7697          sumth1thyb
7698         ihelp=nbend_kcc_Tb(iti)-1
7699         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7700         etheta=etheta+sumth1thyb
7701 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7702         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7703       enddo
7704       return
7705       end subroutine ebend_kcc
7706 !c------------
7707 !c-------------------------------------------------------------------------------------
7708       subroutine etheta_constr(ethetacnstr)
7709       real (kind=8) :: ethetacnstr,thetiii,difi
7710       integer :: i,itheta
7711       ethetacnstr=0.0d0
7712 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7713       do i=ithetaconstr_start,ithetaconstr_end
7714         itheta=itheta_constr(i)
7715         thetiii=theta(itheta)
7716         difi=pinorm(thetiii-theta_constr0(i))
7717         if (difi.gt.theta_drange(i)) then
7718           difi=difi-theta_drange(i)
7719           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7720           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7721          +for_thet_constr(i)*difi**3
7722         else if (difi.lt.-drange(i)) then
7723           difi=difi+drange(i)
7724           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7725           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7726           +for_thet_constr(i)*difi**3
7727         else
7728           difi=0.0
7729         endif
7730        if (energy_dec) then
7731         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7732          i,itheta,rad2deg*thetiii,&
7733          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7734          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7735          gloc(itheta+nphi-2,icg)
7736         endif
7737       enddo
7738       return
7739       end subroutine etheta_constr
7740
7741 !-----------------------------------------------------------------------------
7742       subroutine eback_sc_corr(esccor)
7743 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7744 !        conformational states; temporarily implemented as differences
7745 !        between UNRES torsional potentials (dependent on three types of
7746 !        residues) and the torsional potentials dependent on all 20 types
7747 !        of residues computed from AM1  energy surfaces of terminally-blocked
7748 !        amino-acid residues.
7749 !      implicit real*8 (a-h,o-z)
7750 !      include 'DIMENSIONS'
7751 !      include 'COMMON.VAR'
7752 !      include 'COMMON.GEO'
7753 !      include 'COMMON.LOCAL'
7754 !      include 'COMMON.TORSION'
7755 !      include 'COMMON.SCCOR'
7756 !      include 'COMMON.INTERACT'
7757 !      include 'COMMON.DERIV'
7758 !      include 'COMMON.CHAIN'
7759 !      include 'COMMON.NAMES'
7760 !      include 'COMMON.IOUNITS'
7761 !      include 'COMMON.FFIELD'
7762 !      include 'COMMON.CONTROL'
7763       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7764                    cosphi,sinphi
7765       logical :: lprn
7766       integer :: i,interty,j,isccori,isccori1,intertyp
7767 ! Set lprn=.true. for debugging
7768       lprn=.false.
7769 !      lprn=.true.
7770 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7771       esccor=0.0D0
7772       do i=itau_start,itau_end
7773         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7774         esccor_ii=0.0D0
7775         isccori=isccortyp(itype(i-2,1))
7776         isccori1=isccortyp(itype(i-1,1))
7777
7778 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7779         phii=phi(i)
7780         do intertyp=1,3 !intertyp
7781          esccor_ii=0.0D0
7782 !c Added 09 May 2012 (Adasko)
7783 !c  Intertyp means interaction type of backbone mainchain correlation:
7784 !   1 = SC...Ca...Ca...Ca
7785 !   2 = Ca...Ca...Ca...SC
7786 !   3 = SC...Ca...Ca...SCi
7787         gloci=0.0D0
7788         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7789             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7790             (itype(i-1,1).eq.ntyp1))) &
7791           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7792            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7793            .or.(itype(i,1).eq.ntyp1))) &
7794           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7795             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7796             (itype(i-3,1).eq.ntyp1)))) cycle
7797         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7798         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7799        cycle
7800        do j=1,nterm_sccor(isccori,isccori1)
7801           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7802           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7803           cosphi=dcos(j*tauangle(intertyp,i))
7804           sinphi=dsin(j*tauangle(intertyp,i))
7805           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7806           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7807           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7808         enddo
7809         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7810                                 'esccor',i,intertyp,esccor_ii
7811 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7812         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7813         if (lprn) &
7814         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7815         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7816         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7817         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7818         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7819        enddo !intertyp
7820       enddo
7821
7822       return
7823       end subroutine eback_sc_corr
7824 !-----------------------------------------------------------------------------
7825       subroutine multibody(ecorr)
7826 ! This subroutine calculates multi-body contributions to energy following
7827 ! the idea of Skolnick et al. If side chains I and J make a contact and
7828 ! at the same time side chains I+1 and J+1 make a contact, an extra
7829 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7830 !      implicit real*8 (a-h,o-z)
7831 !      include 'DIMENSIONS'
7832 !      include 'COMMON.IOUNITS'
7833 !      include 'COMMON.DERIV'
7834 !      include 'COMMON.INTERACT'
7835 !      include 'COMMON.CONTACTS'
7836       real(kind=8),dimension(3) :: gx,gx1
7837       logical :: lprn
7838       real(kind=8) :: ecorr
7839       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7840 ! Set lprn=.true. for debugging
7841       lprn=.false.
7842
7843       if (lprn) then
7844         write (iout,'(a)') 'Contact function values:'
7845         do i=nnt,nct-2
7846           write (iout,'(i2,20(1x,i2,f10.5))') &
7847               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7848         enddo
7849       endif
7850       ecorr=0.0D0
7851
7852 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7853 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7854       do i=nnt,nct
7855         do j=1,3
7856           gradcorr(j,i)=0.0D0
7857           gradxorr(j,i)=0.0D0
7858         enddo
7859       enddo
7860       do i=nnt,nct-2
7861
7862         DO ISHIFT = 3,4
7863
7864         i1=i+ishift
7865         num_conti=num_cont(i)
7866         num_conti1=num_cont(i1)
7867         do jj=1,num_conti
7868           j=jcont(jj,i)
7869           do kk=1,num_conti1
7870             j1=jcont(kk,i1)
7871             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7872 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7873 !d   &                   ' ishift=',ishift
7874 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7875 ! The system gains extra energy.
7876               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7877             endif   ! j1==j+-ishift
7878           enddo     ! kk
7879         enddo       ! jj
7880
7881         ENDDO ! ISHIFT
7882
7883       enddo         ! i
7884       return
7885       end subroutine multibody
7886 !-----------------------------------------------------------------------------
7887       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7888 !      implicit real*8 (a-h,o-z)
7889 !      include 'DIMENSIONS'
7890 !      include 'COMMON.IOUNITS'
7891 !      include 'COMMON.DERIV'
7892 !      include 'COMMON.INTERACT'
7893 !      include 'COMMON.CONTACTS'
7894       real(kind=8),dimension(3) :: gx,gx1
7895       logical :: lprn
7896       integer :: i,j,k,l,jj,kk,m,ll
7897       real(kind=8) :: eij,ekl
7898       lprn=.false.
7899       eij=facont(jj,i)
7900       ekl=facont(kk,k)
7901 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7902 ! Calculate the multi-body contribution to energy.
7903 ! Calculate multi-body contributions to the gradient.
7904 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7905 !d   & k,l,(gacont(m,kk,k),m=1,3)
7906       do m=1,3
7907         gx(m) =ekl*gacont(m,jj,i)
7908         gx1(m)=eij*gacont(m,kk,k)
7909         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7910         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7911         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7912         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7913       enddo
7914       do m=i,j-1
7915         do ll=1,3
7916           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7917         enddo
7918       enddo
7919       do m=k,l-1
7920         do ll=1,3
7921           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7922         enddo
7923       enddo
7924       esccorr=-eij*ekl
7925       return
7926       end function esccorr
7927 !-----------------------------------------------------------------------------
7928       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7929 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7930 !      implicit real*8 (a-h,o-z)
7931 !      include 'DIMENSIONS'
7932 !      include 'COMMON.IOUNITS'
7933 #ifdef MPI
7934       include "mpif.h"
7935 !      integer :: maxconts !max_cont=maxconts  =nres/4
7936       integer,parameter :: max_dim=26
7937       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7938       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7939 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7940 !el      common /przechowalnia/ zapas
7941       integer :: status(MPI_STATUS_SIZE)
7942       integer,dimension((nres/4)*2) :: req !maxconts*2
7943       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7944 #endif
7945 !      include 'COMMON.SETUP'
7946 !      include 'COMMON.FFIELD'
7947 !      include 'COMMON.DERIV'
7948 !      include 'COMMON.INTERACT'
7949 !      include 'COMMON.CONTACTS'
7950 !      include 'COMMON.CONTROL'
7951 !      include 'COMMON.LOCAL'
7952       real(kind=8),dimension(3) :: gx,gx1
7953       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7954       logical :: lprn,ldone
7955 !el local variables
7956       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7957               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7958
7959 ! Set lprn=.true. for debugging
7960       lprn=.false.
7961 #ifdef MPI
7962 !      maxconts=nres/4
7963       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7964       n_corr=0
7965       n_corr1=0
7966       if (nfgtasks.le.1) goto 30
7967       if (lprn) then
7968         write (iout,'(a)') 'Contact function values before RECEIVE:'
7969         do i=nnt,nct-2
7970           write (iout,'(2i3,50(1x,i2,f5.2))') &
7971           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7972           j=1,num_cont_hb(i))
7973         enddo
7974       endif
7975       call flush(iout)
7976       do i=1,ntask_cont_from
7977         ncont_recv(i)=0
7978       enddo
7979       do i=1,ntask_cont_to
7980         ncont_sent(i)=0
7981       enddo
7982 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7983 !     & ntask_cont_to
7984 ! Make the list of contacts to send to send to other procesors
7985 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7986 !      call flush(iout)
7987       do i=iturn3_start,iturn3_end
7988 !        write (iout,*) "make contact list turn3",i," num_cont",
7989 !     &    num_cont_hb(i)
7990         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7991       enddo
7992       do i=iturn4_start,iturn4_end
7993 !        write (iout,*) "make contact list turn4",i," num_cont",
7994 !     &   num_cont_hb(i)
7995         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7996       enddo
7997       do ii=1,nat_sent
7998         i=iat_sent(ii)
7999 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8000 !     &    num_cont_hb(i)
8001         do j=1,num_cont_hb(i)
8002         do k=1,4
8003           jjc=jcont_hb(j,i)
8004           iproc=iint_sent_local(k,jjc,ii)
8005 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8006           if (iproc.gt.0) then
8007             ncont_sent(iproc)=ncont_sent(iproc)+1
8008             nn=ncont_sent(iproc)
8009             zapas(1,nn,iproc)=i
8010             zapas(2,nn,iproc)=jjc
8011             zapas(3,nn,iproc)=facont_hb(j,i)
8012             zapas(4,nn,iproc)=ees0p(j,i)
8013             zapas(5,nn,iproc)=ees0m(j,i)
8014             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8015             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8016             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8017             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8018             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8019             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8020             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8021             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8022             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8023             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8024             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8025             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8026             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8027             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8028             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8029             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8030             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8031             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8032             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8033             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8034             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8035           endif
8036         enddo
8037         enddo
8038       enddo
8039       if (lprn) then
8040       write (iout,*) &
8041         "Numbers of contacts to be sent to other processors",&
8042         (ncont_sent(i),i=1,ntask_cont_to)
8043       write (iout,*) "Contacts sent"
8044       do ii=1,ntask_cont_to
8045         nn=ncont_sent(ii)
8046         iproc=itask_cont_to(ii)
8047         write (iout,*) nn," contacts to processor",iproc,&
8048          " of CONT_TO_COMM group"
8049         do i=1,nn
8050           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8051         enddo
8052       enddo
8053       call flush(iout)
8054       endif
8055       CorrelType=477
8056       CorrelID=fg_rank+1
8057       CorrelType1=478
8058       CorrelID1=nfgtasks+fg_rank+1
8059       ireq=0
8060 ! Receive the numbers of needed contacts from other processors
8061       do ii=1,ntask_cont_from
8062         iproc=itask_cont_from(ii)
8063         ireq=ireq+1
8064         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8065           FG_COMM,req(ireq),IERR)
8066       enddo
8067 !      write (iout,*) "IRECV ended"
8068 !      call flush(iout)
8069 ! Send the number of contacts needed by other processors
8070       do ii=1,ntask_cont_to
8071         iproc=itask_cont_to(ii)
8072         ireq=ireq+1
8073         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8074           FG_COMM,req(ireq),IERR)
8075       enddo
8076 !      write (iout,*) "ISEND ended"
8077 !      write (iout,*) "number of requests (nn)",ireq
8078       call flush(iout)
8079       if (ireq.gt.0) &
8080         call MPI_Waitall(ireq,req,status_array,ierr)
8081 !      write (iout,*)
8082 !     &  "Numbers of contacts to be received from other processors",
8083 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8084 !      call flush(iout)
8085 ! Receive contacts
8086       ireq=0
8087       do ii=1,ntask_cont_from
8088         iproc=itask_cont_from(ii)
8089         nn=ncont_recv(ii)
8090 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8091 !     &   " of CONT_TO_COMM group"
8092         call flush(iout)
8093         if (nn.gt.0) then
8094           ireq=ireq+1
8095           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8096           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8097 !          write (iout,*) "ireq,req",ireq,req(ireq)
8098         endif
8099       enddo
8100 ! Send the contacts to processors that need them
8101       do ii=1,ntask_cont_to
8102         iproc=itask_cont_to(ii)
8103         nn=ncont_sent(ii)
8104 !        write (iout,*) nn," contacts to processor",iproc,
8105 !     &   " of CONT_TO_COMM group"
8106         if (nn.gt.0) then
8107           ireq=ireq+1
8108           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8109             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8110 !          write (iout,*) "ireq,req",ireq,req(ireq)
8111 !          do i=1,nn
8112 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8113 !          enddo
8114         endif
8115       enddo
8116 !      write (iout,*) "number of requests (contacts)",ireq
8117 !      write (iout,*) "req",(req(i),i=1,4)
8118 !      call flush(iout)
8119       if (ireq.gt.0) &
8120        call MPI_Waitall(ireq,req,status_array,ierr)
8121       do iii=1,ntask_cont_from
8122         iproc=itask_cont_from(iii)
8123         nn=ncont_recv(iii)
8124         if (lprn) then
8125         write (iout,*) "Received",nn," contacts from processor",iproc,&
8126          " of CONT_FROM_COMM group"
8127         call flush(iout)
8128         do i=1,nn
8129           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8130         enddo
8131         call flush(iout)
8132         endif
8133         do i=1,nn
8134           ii=zapas_recv(1,i,iii)
8135 ! Flag the received contacts to prevent double-counting
8136           jj=-zapas_recv(2,i,iii)
8137 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8138 !          call flush(iout)
8139           nnn=num_cont_hb(ii)+1
8140           num_cont_hb(ii)=nnn
8141           jcont_hb(nnn,ii)=jj
8142           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8143           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8144           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8145           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8146           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8147           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8148           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8149           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8150           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8151           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8152           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8153           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8154           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8155           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8156           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8157           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8158           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8159           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8160           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8161           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8162           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8163           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8164           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8165           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8166         enddo
8167       enddo
8168       call flush(iout)
8169       if (lprn) then
8170         write (iout,'(a)') 'Contact function values after receive:'
8171         do i=nnt,nct-2
8172           write (iout,'(2i3,50(1x,i3,f5.2))') &
8173           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8174           j=1,num_cont_hb(i))
8175         enddo
8176         call flush(iout)
8177       endif
8178    30 continue
8179 #endif
8180       if (lprn) then
8181         write (iout,'(a)') 'Contact function values:'
8182         do i=nnt,nct-2
8183           write (iout,'(2i3,50(1x,i3,f5.2))') &
8184           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8185           j=1,num_cont_hb(i))
8186         enddo
8187       endif
8188       ecorr=0.0D0
8189
8190 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8191 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8192 ! Remove the loop below after debugging !!!
8193       do i=nnt,nct
8194         do j=1,3
8195           gradcorr(j,i)=0.0D0
8196           gradxorr(j,i)=0.0D0
8197         enddo
8198       enddo
8199 ! Calculate the local-electrostatic correlation terms
8200       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8201         i1=i+1
8202         num_conti=num_cont_hb(i)
8203         num_conti1=num_cont_hb(i+1)
8204         do jj=1,num_conti
8205           j=jcont_hb(jj,i)
8206           jp=iabs(j)
8207           do kk=1,num_conti1
8208             j1=jcont_hb(kk,i1)
8209             jp1=iabs(j1)
8210 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8211 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8212             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8213                 .or. j.lt.0 .and. j1.gt.0) .and. &
8214                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8215 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8216 ! The system gains extra energy.
8217               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8218               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8219                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8220               n_corr=n_corr+1
8221             else if (j1.eq.j) then
8222 ! Contacts I-J and I-(J+1) occur simultaneously.
8223 ! The system loses extra energy.
8224 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8225             endif
8226           enddo ! kk
8227           do kk=1,num_conti
8228             j1=jcont_hb(kk,i)
8229 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8230 !    &         ' jj=',jj,' kk=',kk
8231             if (j1.eq.j+1) then
8232 ! Contacts I-J and (I+1)-J occur simultaneously.
8233 ! The system loses extra energy.
8234 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8235             endif ! j1==j+1
8236           enddo ! kk
8237         enddo ! jj
8238       enddo ! i
8239       return
8240       end subroutine multibody_hb
8241 !-----------------------------------------------------------------------------
8242       subroutine add_hb_contact(ii,jj,itask)
8243 !      implicit real*8 (a-h,o-z)
8244 !      include "DIMENSIONS"
8245 !      include "COMMON.IOUNITS"
8246 !      include "COMMON.CONTACTS"
8247 !      integer,parameter :: maxconts=nres/4
8248       integer,parameter :: max_dim=26
8249       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8250 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8251 !      common /przechowalnia/ zapas
8252       integer :: i,j,ii,jj,iproc,nn,jjc
8253       integer,dimension(4) :: itask
8254 !      write (iout,*) "itask",itask
8255       do i=1,2
8256         iproc=itask(i)
8257         if (iproc.gt.0) then
8258           do j=1,num_cont_hb(ii)
8259             jjc=jcont_hb(j,ii)
8260 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8261             if (jjc.eq.jj) then
8262               ncont_sent(iproc)=ncont_sent(iproc)+1
8263               nn=ncont_sent(iproc)
8264               zapas(1,nn,iproc)=ii
8265               zapas(2,nn,iproc)=jjc
8266               zapas(3,nn,iproc)=facont_hb(j,ii)
8267               zapas(4,nn,iproc)=ees0p(j,ii)
8268               zapas(5,nn,iproc)=ees0m(j,ii)
8269               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8270               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8271               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8272               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8273               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8274               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8275               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8276               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8277               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8278               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8279               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8280               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8281               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8282               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8283               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8284               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8285               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8286               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8287               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8288               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8289               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8290               exit
8291             endif
8292           enddo
8293         endif
8294       enddo
8295       return
8296       end subroutine add_hb_contact
8297 !-----------------------------------------------------------------------------
8298       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8299 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8300 !      implicit real*8 (a-h,o-z)
8301 !      include 'DIMENSIONS'
8302 !      include 'COMMON.IOUNITS'
8303       integer,parameter :: max_dim=70
8304 #ifdef MPI
8305       include "mpif.h"
8306 !      integer :: maxconts !max_cont=maxconts=nres/4
8307       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8308       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8309 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8310 !      common /przechowalnia/ zapas
8311       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8312         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8313         ierr,iii,nnn
8314 #endif
8315 !      include 'COMMON.SETUP'
8316 !      include 'COMMON.FFIELD'
8317 !      include 'COMMON.DERIV'
8318 !      include 'COMMON.LOCAL'
8319 !      include 'COMMON.INTERACT'
8320 !      include 'COMMON.CONTACTS'
8321 !      include 'COMMON.CHAIN'
8322 !      include 'COMMON.CONTROL'
8323       real(kind=8),dimension(3) :: gx,gx1
8324       integer,dimension(nres) :: num_cont_hb_old
8325       logical :: lprn,ldone
8326 !EL      double precision eello4,eello5,eelo6,eello_turn6
8327 !EL      external eello4,eello5,eello6,eello_turn6
8328 !el local variables
8329       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8330               j1,jp1,i1,num_conti1
8331       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8332       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8333
8334 ! Set lprn=.true. for debugging
8335       lprn=.false.
8336       eturn6=0.0d0
8337 #ifdef MPI
8338 !      maxconts=nres/4
8339       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8340       do i=1,nres
8341         num_cont_hb_old(i)=num_cont_hb(i)
8342       enddo
8343       n_corr=0
8344       n_corr1=0
8345       if (nfgtasks.le.1) goto 30
8346       if (lprn) then
8347         write (iout,'(a)') 'Contact function values before RECEIVE:'
8348         do i=nnt,nct-2
8349           write (iout,'(2i3,50(1x,i2,f5.2))') &
8350           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8351           j=1,num_cont_hb(i))
8352         enddo
8353       endif
8354       call flush(iout)
8355       do i=1,ntask_cont_from
8356         ncont_recv(i)=0
8357       enddo
8358       do i=1,ntask_cont_to
8359         ncont_sent(i)=0
8360       enddo
8361 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8362 !     & ntask_cont_to
8363 ! Make the list of contacts to send to send to other procesors
8364       do i=iturn3_start,iturn3_end
8365 !        write (iout,*) "make contact list turn3",i," num_cont",
8366 !     &    num_cont_hb(i)
8367         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8368       enddo
8369       do i=iturn4_start,iturn4_end
8370 !        write (iout,*) "make contact list turn4",i," num_cont",
8371 !     &   num_cont_hb(i)
8372         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8373       enddo
8374       do ii=1,nat_sent
8375         i=iat_sent(ii)
8376 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8377 !     &    num_cont_hb(i)
8378         do j=1,num_cont_hb(i)
8379         do k=1,4
8380           jjc=jcont_hb(j,i)
8381           iproc=iint_sent_local(k,jjc,ii)
8382 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8383           if (iproc.ne.0) then
8384             ncont_sent(iproc)=ncont_sent(iproc)+1
8385             nn=ncont_sent(iproc)
8386             zapas(1,nn,iproc)=i
8387             zapas(2,nn,iproc)=jjc
8388             zapas(3,nn,iproc)=d_cont(j,i)
8389             ind=3
8390             do kk=1,3
8391               ind=ind+1
8392               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8393             enddo
8394             do kk=1,2
8395               do ll=1,2
8396                 ind=ind+1
8397                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8398               enddo
8399             enddo
8400             do jj=1,5
8401               do kk=1,3
8402                 do ll=1,2
8403                   do mm=1,2
8404                     ind=ind+1
8405                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8406                   enddo
8407                 enddo
8408               enddo
8409             enddo
8410           endif
8411         enddo
8412         enddo
8413       enddo
8414       if (lprn) then
8415       write (iout,*) &
8416         "Numbers of contacts to be sent to other processors",&
8417         (ncont_sent(i),i=1,ntask_cont_to)
8418       write (iout,*) "Contacts sent"
8419       do ii=1,ntask_cont_to
8420         nn=ncont_sent(ii)
8421         iproc=itask_cont_to(ii)
8422         write (iout,*) nn," contacts to processor",iproc,&
8423          " of CONT_TO_COMM group"
8424         do i=1,nn
8425           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8426         enddo
8427       enddo
8428       call flush(iout)
8429       endif
8430       CorrelType=477
8431       CorrelID=fg_rank+1
8432       CorrelType1=478
8433       CorrelID1=nfgtasks+fg_rank+1
8434       ireq=0
8435 ! Receive the numbers of needed contacts from other processors
8436       do ii=1,ntask_cont_from
8437         iproc=itask_cont_from(ii)
8438         ireq=ireq+1
8439         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8440           FG_COMM,req(ireq),IERR)
8441       enddo
8442 !      write (iout,*) "IRECV ended"
8443 !      call flush(iout)
8444 ! Send the number of contacts needed by other processors
8445       do ii=1,ntask_cont_to
8446         iproc=itask_cont_to(ii)
8447         ireq=ireq+1
8448         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8449           FG_COMM,req(ireq),IERR)
8450       enddo
8451 !      write (iout,*) "ISEND ended"
8452 !      write (iout,*) "number of requests (nn)",ireq
8453       call flush(iout)
8454       if (ireq.gt.0) &
8455         call MPI_Waitall(ireq,req,status_array,ierr)
8456 !      write (iout,*)
8457 !     &  "Numbers of contacts to be received from other processors",
8458 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8459 !      call flush(iout)
8460 ! Receive contacts
8461       ireq=0
8462       do ii=1,ntask_cont_from
8463         iproc=itask_cont_from(ii)
8464         nn=ncont_recv(ii)
8465 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8466 !     &   " of CONT_TO_COMM group"
8467         call flush(iout)
8468         if (nn.gt.0) then
8469           ireq=ireq+1
8470           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8471           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8472 !          write (iout,*) "ireq,req",ireq,req(ireq)
8473         endif
8474       enddo
8475 ! Send the contacts to processors that need them
8476       do ii=1,ntask_cont_to
8477         iproc=itask_cont_to(ii)
8478         nn=ncont_sent(ii)
8479 !        write (iout,*) nn," contacts to processor",iproc,
8480 !     &   " of CONT_TO_COMM group"
8481         if (nn.gt.0) then
8482           ireq=ireq+1
8483           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8484             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8485 !          write (iout,*) "ireq,req",ireq,req(ireq)
8486 !          do i=1,nn
8487 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8488 !          enddo
8489         endif
8490       enddo
8491 !      write (iout,*) "number of requests (contacts)",ireq
8492 !      write (iout,*) "req",(req(i),i=1,4)
8493 !      call flush(iout)
8494       if (ireq.gt.0) &
8495        call MPI_Waitall(ireq,req,status_array,ierr)
8496       do iii=1,ntask_cont_from
8497         iproc=itask_cont_from(iii)
8498         nn=ncont_recv(iii)
8499         if (lprn) then
8500         write (iout,*) "Received",nn," contacts from processor",iproc,&
8501          " of CONT_FROM_COMM group"
8502         call flush(iout)
8503         do i=1,nn
8504           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8505         enddo
8506         call flush(iout)
8507         endif
8508         do i=1,nn
8509           ii=zapas_recv(1,i,iii)
8510 ! Flag the received contacts to prevent double-counting
8511           jj=-zapas_recv(2,i,iii)
8512 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8513 !          call flush(iout)
8514           nnn=num_cont_hb(ii)+1
8515           num_cont_hb(ii)=nnn
8516           jcont_hb(nnn,ii)=jj
8517           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8518           ind=3
8519           do kk=1,3
8520             ind=ind+1
8521             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8522           enddo
8523           do kk=1,2
8524             do ll=1,2
8525               ind=ind+1
8526               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8527             enddo
8528           enddo
8529           do jj=1,5
8530             do kk=1,3
8531               do ll=1,2
8532                 do mm=1,2
8533                   ind=ind+1
8534                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8535                 enddo
8536               enddo
8537             enddo
8538           enddo
8539         enddo
8540       enddo
8541       call flush(iout)
8542       if (lprn) then
8543         write (iout,'(a)') 'Contact function values after receive:'
8544         do i=nnt,nct-2
8545           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8546           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8547           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8548         enddo
8549         call flush(iout)
8550       endif
8551    30 continue
8552 #endif
8553       if (lprn) then
8554         write (iout,'(a)') 'Contact function values:'
8555         do i=nnt,nct-2
8556           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8557           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8558           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8559         enddo
8560       endif
8561       ecorr=0.0D0
8562       ecorr5=0.0d0
8563       ecorr6=0.0d0
8564
8565 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8566 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8567 ! Remove the loop below after debugging !!!
8568       do i=nnt,nct
8569         do j=1,3
8570           gradcorr(j,i)=0.0D0
8571           gradxorr(j,i)=0.0D0
8572         enddo
8573       enddo
8574 ! Calculate the dipole-dipole interaction energies
8575       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8576       do i=iatel_s,iatel_e+1
8577         num_conti=num_cont_hb(i)
8578         do jj=1,num_conti
8579           j=jcont_hb(jj,i)
8580 #ifdef MOMENT
8581           call dipole(i,j,jj)
8582 #endif
8583         enddo
8584       enddo
8585       endif
8586 ! Calculate the local-electrostatic correlation terms
8587 !                write (iout,*) "gradcorr5 in eello5 before loop"
8588 !                do iii=1,nres
8589 !                  write (iout,'(i5,3f10.5)')
8590 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8591 !                enddo
8592       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8593 !        write (iout,*) "corr loop i",i
8594         i1=i+1
8595         num_conti=num_cont_hb(i)
8596         num_conti1=num_cont_hb(i+1)
8597         do jj=1,num_conti
8598           j=jcont_hb(jj,i)
8599           jp=iabs(j)
8600           do kk=1,num_conti1
8601             j1=jcont_hb(kk,i1)
8602             jp1=iabs(j1)
8603 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8604 !     &         ' jj=',jj,' kk=',kk
8605 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8606             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8607                 .or. j.lt.0 .and. j1.gt.0) .and. &
8608                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8609 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8610 ! The system gains extra energy.
8611               n_corr=n_corr+1
8612               sqd1=dsqrt(d_cont(jj,i))
8613               sqd2=dsqrt(d_cont(kk,i1))
8614               sred_geom = sqd1*sqd2
8615               IF (sred_geom.lt.cutoff_corr) THEN
8616                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8617                   ekont,fprimcont)
8618 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8619 !d     &         ' jj=',jj,' kk=',kk
8620                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8621                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8622                 do l=1,3
8623                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8624                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8625                 enddo
8626                 n_corr1=n_corr1+1
8627 !d               write (iout,*) 'sred_geom=',sred_geom,
8628 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8629 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8630 !d               write (iout,*) "g_contij",g_contij
8631 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8632 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8633                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8634                 if (wcorr4.gt.0.0d0) &
8635                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8636                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8637                        write (iout,'(a6,4i5,0pf7.3)') &
8638                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8639 !                write (iout,*) "gradcorr5 before eello5"
8640 !                do iii=1,nres
8641 !                  write (iout,'(i5,3f10.5)')
8642 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8643 !                enddo
8644                 if (wcorr5.gt.0.0d0) &
8645                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8646 !                write (iout,*) "gradcorr5 after eello5"
8647 !                do iii=1,nres
8648 !                  write (iout,'(i5,3f10.5)')
8649 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8650 !                enddo
8651                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8652                        write (iout,'(a6,4i5,0pf7.3)') &
8653                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8654 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8655 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8656                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8657                      .or. wturn6.eq.0.0d0))then
8658 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8659                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8660                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8661                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8662 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8663 !d     &            'ecorr6=',ecorr6
8664 !d                write (iout,'(4e15.5)') sred_geom,
8665 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8666 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8667 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8668                 else if (wturn6.gt.0.0d0 &
8669                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8670 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8671                   eturn6=eturn6+eello_turn6(i,jj,kk)
8672                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8673                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8674 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8675                 endif
8676               ENDIF
8677 1111          continue
8678             endif
8679           enddo ! kk
8680         enddo ! jj
8681       enddo ! i
8682       do i=1,nres
8683         num_cont_hb(i)=num_cont_hb_old(i)
8684       enddo
8685 !                write (iout,*) "gradcorr5 in eello5"
8686 !                do iii=1,nres
8687 !                  write (iout,'(i5,3f10.5)')
8688 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8689 !                enddo
8690       return
8691       end subroutine multibody_eello
8692 !-----------------------------------------------------------------------------
8693       subroutine add_hb_contact_eello(ii,jj,itask)
8694 !      implicit real*8 (a-h,o-z)
8695 !      include "DIMENSIONS"
8696 !      include "COMMON.IOUNITS"
8697 !      include "COMMON.CONTACTS"
8698 !      integer,parameter :: maxconts=nres/4
8699       integer,parameter :: max_dim=70
8700       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8701 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8702 !      common /przechowalnia/ zapas
8703
8704       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8705       integer,dimension(4) ::itask
8706 !      write (iout,*) "itask",itask
8707       do i=1,2
8708         iproc=itask(i)
8709         if (iproc.gt.0) then
8710           do j=1,num_cont_hb(ii)
8711             jjc=jcont_hb(j,ii)
8712 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8713             if (jjc.eq.jj) then
8714               ncont_sent(iproc)=ncont_sent(iproc)+1
8715               nn=ncont_sent(iproc)
8716               zapas(1,nn,iproc)=ii
8717               zapas(2,nn,iproc)=jjc
8718               zapas(3,nn,iproc)=d_cont(j,ii)
8719               ind=3
8720               do kk=1,3
8721                 ind=ind+1
8722                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8723               enddo
8724               do kk=1,2
8725                 do ll=1,2
8726                   ind=ind+1
8727                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8728                 enddo
8729               enddo
8730               do jj=1,5
8731                 do kk=1,3
8732                   do ll=1,2
8733                     do mm=1,2
8734                       ind=ind+1
8735                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8736                     enddo
8737                   enddo
8738                 enddo
8739               enddo
8740               exit
8741             endif
8742           enddo
8743         endif
8744       enddo
8745       return
8746       end subroutine add_hb_contact_eello
8747 !-----------------------------------------------------------------------------
8748       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8749 !      implicit real*8 (a-h,o-z)
8750 !      include 'DIMENSIONS'
8751 !      include 'COMMON.IOUNITS'
8752 !      include 'COMMON.DERIV'
8753 !      include 'COMMON.INTERACT'
8754 !      include 'COMMON.CONTACTS'
8755       real(kind=8),dimension(3) :: gx,gx1
8756       logical :: lprn
8757 !el local variables
8758       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8759       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8760                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8761                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8762                    rlocshield
8763
8764       lprn=.false.
8765       eij=facont_hb(jj,i)
8766       ekl=facont_hb(kk,k)
8767       ees0pij=ees0p(jj,i)
8768       ees0pkl=ees0p(kk,k)
8769       ees0mij=ees0m(jj,i)
8770       ees0mkl=ees0m(kk,k)
8771       ekont=eij*ekl
8772       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8773 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8774 ! Following 4 lines for diagnostics.
8775 !d    ees0pkl=0.0D0
8776 !d    ees0pij=1.0D0
8777 !d    ees0mkl=0.0D0
8778 !d    ees0mij=1.0D0
8779 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8780 !     & 'Contacts ',i,j,
8781 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8782 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8783 !     & 'gradcorr_long'
8784 ! Calculate the multi-body contribution to energy.
8785 !      ecorr=ecorr+ekont*ees
8786 ! Calculate multi-body contributions to the gradient.
8787       coeffpees0pij=coeffp*ees0pij
8788       coeffmees0mij=coeffm*ees0mij
8789       coeffpees0pkl=coeffp*ees0pkl
8790       coeffmees0mkl=coeffm*ees0mkl
8791       do ll=1,3
8792 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8793         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8794         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8795         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8796         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8797         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8798         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8799 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8800         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8801         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8802         coeffmees0mij*gacontm_hb1(ll,kk,k))
8803         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8804         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8805         coeffmees0mij*gacontm_hb2(ll,kk,k))
8806         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8807            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8808            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8809         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8810         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8811         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8812            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8813            coeffmees0mij*gacontm_hb3(ll,kk,k))
8814         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8815         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8816 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8817       enddo
8818 !      write (iout,*)
8819 !grad      do m=i+1,j-1
8820 !grad        do ll=1,3
8821 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8822 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8823 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8824 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8825 !grad        enddo
8826 !grad      enddo
8827 !grad      do m=k+1,l-1
8828 !grad        do ll=1,3
8829 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8830 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8831 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8832 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8833 !grad        enddo
8834 !grad      enddo
8835 !      write (iout,*) "ehbcorr",ekont*ees
8836       ehbcorr=ekont*ees
8837       if (shield_mode.gt.0) then
8838        j=ees0plist(jj,i)
8839        l=ees0plist(kk,k)
8840 !C        print *,i,j,fac_shield(i),fac_shield(j),
8841 !C     &fac_shield(k),fac_shield(l)
8842         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8843            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8844           do ilist=1,ishield_list(i)
8845            iresshield=shield_list(ilist,i)
8846            do m=1,3
8847            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8848            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8849                    rlocshield  &
8850             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8851             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8852             +rlocshield
8853            enddo
8854           enddo
8855           do ilist=1,ishield_list(j)
8856            iresshield=shield_list(ilist,j)
8857            do m=1,3
8858            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8859            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8860                    rlocshield &
8861             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8862            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8863             +rlocshield
8864            enddo
8865           enddo
8866
8867           do ilist=1,ishield_list(k)
8868            iresshield=shield_list(ilist,k)
8869            do m=1,3
8870            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8871            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8872                    rlocshield &
8873             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8874            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8875             +rlocshield
8876            enddo
8877           enddo
8878           do ilist=1,ishield_list(l)
8879            iresshield=shield_list(ilist,l)
8880            do m=1,3
8881            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8882            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8883                    rlocshield &
8884             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8885            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8886             +rlocshield
8887            enddo
8888           enddo
8889           do m=1,3
8890             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8891                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8892             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8893                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8894             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8895                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8896             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8897                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8898
8899             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8900                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8901             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8902                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8903             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8904                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8905             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8906                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8907
8908            enddo
8909       endif
8910       endif
8911       return
8912       end function ehbcorr
8913 #ifdef MOMENT
8914 !-----------------------------------------------------------------------------
8915       subroutine dipole(i,j,jj)
8916 !      implicit real*8 (a-h,o-z)
8917 !      include 'DIMENSIONS'
8918 !      include 'COMMON.IOUNITS'
8919 !      include 'COMMON.CHAIN'
8920 !      include 'COMMON.FFIELD'
8921 !      include 'COMMON.DERIV'
8922 !      include 'COMMON.INTERACT'
8923 !      include 'COMMON.CONTACTS'
8924 !      include 'COMMON.TORSION'
8925 !      include 'COMMON.VAR'
8926 !      include 'COMMON.GEO'
8927       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8928       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8929       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8930
8931       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8932       allocate(dipderx(3,5,4,maxconts,nres))
8933 !
8934
8935       iti1 = itortyp(itype(i+1,1))
8936       if (j.lt.nres-1) then
8937         itj1 = itype2loc(itype(j+1,1))
8938       else
8939         itj1=nloctyp
8940       endif
8941       do iii=1,2
8942         dipi(iii,1)=Ub2(iii,i)
8943         dipderi(iii)=Ub2der(iii,i)
8944         dipi(iii,2)=b1(iii,iti1)
8945         dipj(iii,1)=Ub2(iii,j)
8946         dipderj(iii)=Ub2der(iii,j)
8947         dipj(iii,2)=b1(iii,itj1)
8948       enddo
8949       kkk=0
8950       do iii=1,2
8951         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8952         do jjj=1,2
8953           kkk=kkk+1
8954           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8955         enddo
8956       enddo
8957       do kkk=1,5
8958         do lll=1,3
8959           mmm=0
8960           do iii=1,2
8961             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8962               auxvec(1))
8963             do jjj=1,2
8964               mmm=mmm+1
8965               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8966             enddo
8967           enddo
8968         enddo
8969       enddo
8970       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8971       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8972       do iii=1,2
8973         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8974       enddo
8975       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8976       do iii=1,2
8977         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8978       enddo
8979       return
8980       end subroutine dipole
8981 #endif
8982 !-----------------------------------------------------------------------------
8983       subroutine calc_eello(i,j,k,l,jj,kk)
8984 !
8985 ! This subroutine computes matrices and vectors needed to calculate
8986 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8987 !
8988       use comm_kut
8989 !      implicit real*8 (a-h,o-z)
8990 !      include 'DIMENSIONS'
8991 !      include 'COMMON.IOUNITS'
8992 !      include 'COMMON.CHAIN'
8993 !      include 'COMMON.DERIV'
8994 !      include 'COMMON.INTERACT'
8995 !      include 'COMMON.CONTACTS'
8996 !      include 'COMMON.TORSION'
8997 !      include 'COMMON.VAR'
8998 !      include 'COMMON.GEO'
8999 !      include 'COMMON.FFIELD'
9000       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9001       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9002       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9003               itj1
9004 !el      logical :: lprn
9005 !el      common /kutas/ lprn
9006 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9007 !d     & ' jj=',jj,' kk=',kk
9008 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9009 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9010 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9011       do iii=1,2
9012         do jjj=1,2
9013           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9014           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9015         enddo
9016       enddo
9017       call transpose2(aa1(1,1),aa1t(1,1))
9018       call transpose2(aa2(1,1),aa2t(1,1))
9019       do kkk=1,5
9020         do lll=1,3
9021           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9022             aa1tder(1,1,lll,kkk))
9023           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9024             aa2tder(1,1,lll,kkk))
9025         enddo
9026       enddo
9027       if (l.eq.j+1) then
9028 ! parallel orientation of the two CA-CA-CA frames.
9029         if (i.gt.1) then
9030           iti=itortyp(itype(i,1))
9031         else
9032           iti=ntortyp+1
9033         endif
9034         itk1=itortyp(itype(k+1,1))
9035         itj=itortyp(itype(j,1))
9036         if (l.lt.nres-1) then
9037           itl1=itortyp(itype(l+1,1))
9038         else
9039           itl1=ntortyp+1
9040         endif
9041 ! A1 kernel(j+1) A2T
9042 !d        do iii=1,2
9043 !d          write (iout,'(3f10.5,5x,3f10.5)')
9044 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9045 !d        enddo
9046         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9047          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9048          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9049 ! Following matrices are needed only for 6-th order cumulants
9050         IF (wcorr6.gt.0.0d0) THEN
9051         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9052          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9053          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9054         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9055          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9056          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9057          ADtEAderx(1,1,1,1,1,1))
9058         lprn=.false.
9059         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9060          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9061          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9062          ADtEA1derx(1,1,1,1,1,1))
9063         ENDIF
9064 ! End 6-th order cumulants
9065 !d        lprn=.false.
9066 !d        if (lprn) then
9067 !d        write (2,*) 'In calc_eello6'
9068 !d        do iii=1,2
9069 !d          write (2,*) 'iii=',iii
9070 !d          do kkk=1,5
9071 !d            write (2,*) 'kkk=',kkk
9072 !d            do jjj=1,2
9073 !d              write (2,'(3(2f10.5),5x)')
9074 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9075 !d            enddo
9076 !d          enddo
9077 !d        enddo
9078 !d        endif
9079         call transpose2(EUgder(1,1,k),auxmat(1,1))
9080         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9081         call transpose2(EUg(1,1,k),auxmat(1,1))
9082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9083         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9084         do iii=1,2
9085           do kkk=1,5
9086             do lll=1,3
9087               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9088                 EAEAderx(1,1,lll,kkk,iii,1))
9089             enddo
9090           enddo
9091         enddo
9092 ! A1T kernel(i+1) A2
9093         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9094          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9095          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9096 ! Following matrices are needed only for 6-th order cumulants
9097         IF (wcorr6.gt.0.0d0) THEN
9098         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9099          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9100          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9101         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9102          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9103          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9104          ADtEAderx(1,1,1,1,1,2))
9105         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9106          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9107          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9108          ADtEA1derx(1,1,1,1,1,2))
9109         ENDIF
9110 ! End 6-th order cumulants
9111         call transpose2(EUgder(1,1,l),auxmat(1,1))
9112         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9113         call transpose2(EUg(1,1,l),auxmat(1,1))
9114         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9115         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9116         do iii=1,2
9117           do kkk=1,5
9118             do lll=1,3
9119               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9120                 EAEAderx(1,1,lll,kkk,iii,2))
9121             enddo
9122           enddo
9123         enddo
9124 ! AEAb1 and AEAb2
9125 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9126 ! They are needed only when the fifth- or the sixth-order cumulants are
9127 ! indluded.
9128         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9129         call transpose2(AEA(1,1,1),auxmat(1,1))
9130         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9131         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9132         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9133         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9134         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9135         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9136         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9137         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9138         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9139         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9140         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9141         call transpose2(AEA(1,1,2),auxmat(1,1))
9142         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9143         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9144         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9145         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9146         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9147         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9148         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9149         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9150         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9151         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9152         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9153 ! Calculate the Cartesian derivatives of the vectors.
9154         do iii=1,2
9155           do kkk=1,5
9156             do lll=1,3
9157               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9158               call matvec2(auxmat(1,1),b1(1,iti),&
9159                 AEAb1derx(1,lll,kkk,iii,1,1))
9160               call matvec2(auxmat(1,1),Ub2(1,i),&
9161                 AEAb2derx(1,lll,kkk,iii,1,1))
9162               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9163                 AEAb1derx(1,lll,kkk,iii,2,1))
9164               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9165                 AEAb2derx(1,lll,kkk,iii,2,1))
9166               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9167               call matvec2(auxmat(1,1),b1(1,itj),&
9168                 AEAb1derx(1,lll,kkk,iii,1,2))
9169               call matvec2(auxmat(1,1),Ub2(1,j),&
9170                 AEAb2derx(1,lll,kkk,iii,1,2))
9171               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9172                 AEAb1derx(1,lll,kkk,iii,2,2))
9173               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9174                 AEAb2derx(1,lll,kkk,iii,2,2))
9175             enddo
9176           enddo
9177         enddo
9178         ENDIF
9179 ! End vectors
9180       else
9181 ! Antiparallel orientation of the two CA-CA-CA frames.
9182         if (i.gt.1) then
9183           iti=itortyp(itype(i,1))
9184         else
9185           iti=ntortyp+1
9186         endif
9187         itk1=itortyp(itype(k+1,1))
9188         itl=itortyp(itype(l,1))
9189         itj=itortyp(itype(j,1))
9190         if (j.lt.nres-1) then
9191           itj1=itortyp(itype(j+1,1))
9192         else
9193           itj1=ntortyp+1
9194         endif
9195 ! A2 kernel(j-1)T A1T
9196         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9197          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9198          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9199 ! Following matrices are needed only for 6-th order cumulants
9200         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9201            j.eq.i+4 .and. l.eq.i+3)) THEN
9202         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9203          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9204          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9205         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9206          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9207          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9208          ADtEAderx(1,1,1,1,1,1))
9209         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9210          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9211          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9212          ADtEA1derx(1,1,1,1,1,1))
9213         ENDIF
9214 ! End 6-th order cumulants
9215         call transpose2(EUgder(1,1,k),auxmat(1,1))
9216         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9217         call transpose2(EUg(1,1,k),auxmat(1,1))
9218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9219         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9220         do iii=1,2
9221           do kkk=1,5
9222             do lll=1,3
9223               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9224                 EAEAderx(1,1,lll,kkk,iii,1))
9225             enddo
9226           enddo
9227         enddo
9228 ! A2T kernel(i+1)T A1
9229         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9230          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9231          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9232 ! Following matrices are needed only for 6-th order cumulants
9233         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9234            j.eq.i+4 .and. l.eq.i+3)) THEN
9235         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9236          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9237          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9238         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9239          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9240          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9241          ADtEAderx(1,1,1,1,1,2))
9242         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9243          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9244          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9245          ADtEA1derx(1,1,1,1,1,2))
9246         ENDIF
9247 ! End 6-th order cumulants
9248         call transpose2(EUgder(1,1,j),auxmat(1,1))
9249         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9250         call transpose2(EUg(1,1,j),auxmat(1,1))
9251         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9252         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9253         do iii=1,2
9254           do kkk=1,5
9255             do lll=1,3
9256               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9257                 EAEAderx(1,1,lll,kkk,iii,2))
9258             enddo
9259           enddo
9260         enddo
9261 ! AEAb1 and AEAb2
9262 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9263 ! They are needed only when the fifth- or the sixth-order cumulants are
9264 ! indluded.
9265         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9266           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9267         call transpose2(AEA(1,1,1),auxmat(1,1))
9268         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9269         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9270         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9271         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9272         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9273         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9274         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9275         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9276         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9277         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9278         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9279         call transpose2(AEA(1,1,2),auxmat(1,1))
9280         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9281         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9282         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9283         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9284         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9285         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9286         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9287         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9288         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9289         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9290         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9291 ! Calculate the Cartesian derivatives of the vectors.
9292         do iii=1,2
9293           do kkk=1,5
9294             do lll=1,3
9295               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9296               call matvec2(auxmat(1,1),b1(1,iti),&
9297                 AEAb1derx(1,lll,kkk,iii,1,1))
9298               call matvec2(auxmat(1,1),Ub2(1,i),&
9299                 AEAb2derx(1,lll,kkk,iii,1,1))
9300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9301                 AEAb1derx(1,lll,kkk,iii,2,1))
9302               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9303                 AEAb2derx(1,lll,kkk,iii,2,1))
9304               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9305               call matvec2(auxmat(1,1),b1(1,itl),&
9306                 AEAb1derx(1,lll,kkk,iii,1,2))
9307               call matvec2(auxmat(1,1),Ub2(1,l),&
9308                 AEAb2derx(1,lll,kkk,iii,1,2))
9309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9310                 AEAb1derx(1,lll,kkk,iii,2,2))
9311               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9312                 AEAb2derx(1,lll,kkk,iii,2,2))
9313             enddo
9314           enddo
9315         enddo
9316         ENDIF
9317 ! End vectors
9318       endif
9319       return
9320       end subroutine calc_eello
9321 !-----------------------------------------------------------------------------
9322       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9323       use comm_kut
9324       implicit none
9325       integer :: nderg
9326       logical :: transp
9327       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9328       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9329       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9330       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9331       integer :: iii,kkk,lll
9332       integer :: jjj,mmm
9333 !el      logical :: lprn
9334 !el      common /kutas/ lprn
9335       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9336       do iii=1,nderg
9337         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9338           AKAderg(1,1,iii))
9339       enddo
9340 !d      if (lprn) write (2,*) 'In kernel'
9341       do kkk=1,5
9342 !d        if (lprn) write (2,*) 'kkk=',kkk
9343         do lll=1,3
9344           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9345             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9346 !d          if (lprn) then
9347 !d            write (2,*) 'lll=',lll
9348 !d            write (2,*) 'iii=1'
9349 !d            do jjj=1,2
9350 !d              write (2,'(3(2f10.5),5x)')
9351 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9352 !d            enddo
9353 !d          endif
9354           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9355             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9356 !d          if (lprn) then
9357 !d            write (2,*) 'lll=',lll
9358 !d            write (2,*) 'iii=2'
9359 !d            do jjj=1,2
9360 !d              write (2,'(3(2f10.5),5x)')
9361 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9362 !d            enddo
9363 !d          endif
9364         enddo
9365       enddo
9366       return
9367       end subroutine kernel
9368 !-----------------------------------------------------------------------------
9369       real(kind=8) function eello4(i,j,k,l,jj,kk)
9370 !      implicit real*8 (a-h,o-z)
9371 !      include 'DIMENSIONS'
9372 !      include 'COMMON.IOUNITS'
9373 !      include 'COMMON.CHAIN'
9374 !      include 'COMMON.DERIV'
9375 !      include 'COMMON.INTERACT'
9376 !      include 'COMMON.CONTACTS'
9377 !      include 'COMMON.TORSION'
9378 !      include 'COMMON.VAR'
9379 !      include 'COMMON.GEO'
9380       real(kind=8),dimension(2,2) :: pizda
9381       real(kind=8),dimension(3) :: ggg1,ggg2
9382       real(kind=8) ::  eel4,glongij,glongkl
9383       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9384 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9385 !d        eello4=0.0d0
9386 !d        return
9387 !d      endif
9388 !d      print *,'eello4:',i,j,k,l,jj,kk
9389 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9390 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9391 !old      eij=facont_hb(jj,i)
9392 !old      ekl=facont_hb(kk,k)
9393 !old      ekont=eij*ekl
9394       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9395 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9396       gcorr_loc(k-1)=gcorr_loc(k-1) &
9397          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9398       if (l.eq.j+1) then
9399         gcorr_loc(l-1)=gcorr_loc(l-1) &
9400            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9401       else
9402         gcorr_loc(j-1)=gcorr_loc(j-1) &
9403            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9404       endif
9405       do iii=1,2
9406         do kkk=1,5
9407           do lll=1,3
9408             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9409                               -EAEAderx(2,2,lll,kkk,iii,1)
9410 !d            derx(lll,kkk,iii)=0.0d0
9411           enddo
9412         enddo
9413       enddo
9414 !d      gcorr_loc(l-1)=0.0d0
9415 !d      gcorr_loc(j-1)=0.0d0
9416 !d      gcorr_loc(k-1)=0.0d0
9417 !d      eel4=1.0d0
9418 !d      write (iout,*)'Contacts have occurred for peptide groups',
9419 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9420 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9421       if (j.lt.nres-1) then
9422         j1=j+1
9423         j2=j-1
9424       else
9425         j1=j-1
9426         j2=j-2
9427       endif
9428       if (l.lt.nres-1) then
9429         l1=l+1
9430         l2=l-1
9431       else
9432         l1=l-1
9433         l2=l-2
9434       endif
9435       do ll=1,3
9436 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9437 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9438         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9439         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9440 !grad        ghalf=0.5d0*ggg1(ll)
9441         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9442         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9443         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9444         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9445         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9446         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9447 !grad        ghalf=0.5d0*ggg2(ll)
9448         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9449         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9450         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9451         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9452         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9453         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9454       enddo
9455 !grad      do m=i+1,j-1
9456 !grad        do ll=1,3
9457 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9458 !grad        enddo
9459 !grad      enddo
9460 !grad      do m=k+1,l-1
9461 !grad        do ll=1,3
9462 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9463 !grad        enddo
9464 !grad      enddo
9465 !grad      do m=i+2,j2
9466 !grad        do ll=1,3
9467 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9468 !grad        enddo
9469 !grad      enddo
9470 !grad      do m=k+2,l2
9471 !grad        do ll=1,3
9472 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9473 !grad        enddo
9474 !grad      enddo
9475 !d      do iii=1,nres-3
9476 !d        write (2,*) iii,gcorr_loc(iii)
9477 !d      enddo
9478       eello4=ekont*eel4
9479 !d      write (2,*) 'ekont',ekont
9480 !d      write (iout,*) 'eello4',ekont*eel4
9481       return
9482       end function eello4
9483 !-----------------------------------------------------------------------------
9484       real(kind=8) function eello5(i,j,k,l,jj,kk)
9485 !      implicit real*8 (a-h,o-z)
9486 !      include 'DIMENSIONS'
9487 !      include 'COMMON.IOUNITS'
9488 !      include 'COMMON.CHAIN'
9489 !      include 'COMMON.DERIV'
9490 !      include 'COMMON.INTERACT'
9491 !      include 'COMMON.CONTACTS'
9492 !      include 'COMMON.TORSION'
9493 !      include 'COMMON.VAR'
9494 !      include 'COMMON.GEO'
9495       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9496       real(kind=8),dimension(2) :: vv
9497       real(kind=8),dimension(3) :: ggg1,ggg2
9498       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9499       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9500       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9501 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9502 !                                                                              C
9503 !                            Parallel chains                                   C
9504 !                                                                              C
9505 !          o             o                   o             o                   C
9506 !         /l\           / \             \   / \           / \   /              C
9507 !        /   \         /   \             \ /   \         /   \ /               C
9508 !       j| o |l1       | o |                o| o |         | o |o                C
9509 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9510 !      \i/   \         /   \ /             /   \         /   \                 C
9511 !       o    k1             o                                                  C
9512 !         (I)          (II)                (III)          (IV)                 C
9513 !                                                                              C
9514 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9515 !                                                                              C
9516 !                            Antiparallel chains                               C
9517 !                                                                              C
9518 !          o             o                   o             o                   C
9519 !         /j\           / \             \   / \           / \   /              C
9520 !        /   \         /   \             \ /   \         /   \ /               C
9521 !      j1| o |l        | o |                o| o |         | o |o                C
9522 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9523 !      \i/   \         /   \ /             /   \         /   \                 C
9524 !       o     k1            o                                                  C
9525 !         (I)          (II)                (III)          (IV)                 C
9526 !                                                                              C
9527 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9528 !                                                                              C
9529 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9530 !                                                                              C
9531 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9532 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9533 !d        eello5=0.0d0
9534 !d        return
9535 !d      endif
9536 !d      write (iout,*)
9537 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9538 !d     &   ' and',k,l
9539       itk=itortyp(itype(k,1))
9540       itl=itortyp(itype(l,1))
9541       itj=itortyp(itype(j,1))
9542       eello5_1=0.0d0
9543       eello5_2=0.0d0
9544       eello5_3=0.0d0
9545       eello5_4=0.0d0
9546 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9547 !d     &   eel5_3_num,eel5_4_num)
9548       do iii=1,2
9549         do kkk=1,5
9550           do lll=1,3
9551             derx(lll,kkk,iii)=0.0d0
9552           enddo
9553         enddo
9554       enddo
9555 !d      eij=facont_hb(jj,i)
9556 !d      ekl=facont_hb(kk,k)
9557 !d      ekont=eij*ekl
9558 !d      write (iout,*)'Contacts have occurred for peptide groups',
9559 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9560 !d      goto 1111
9561 ! Contribution from the graph I.
9562 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9563 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9564       call transpose2(EUg(1,1,k),auxmat(1,1))
9565       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9566       vv(1)=pizda(1,1)-pizda(2,2)
9567       vv(2)=pizda(1,2)+pizda(2,1)
9568       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9569        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9570 ! Explicit gradient in virtual-dihedral angles.
9571       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9572        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9573        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9574       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9575       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9576       vv(1)=pizda(1,1)-pizda(2,2)
9577       vv(2)=pizda(1,2)+pizda(2,1)
9578       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9579        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9580        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9581       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9582       vv(1)=pizda(1,1)-pizda(2,2)
9583       vv(2)=pizda(1,2)+pizda(2,1)
9584       if (l.eq.j+1) then
9585         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9586          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9587          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9588       else
9589         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9590          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9591          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9592       endif
9593 ! Cartesian gradient
9594       do iii=1,2
9595         do kkk=1,5
9596           do lll=1,3
9597             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9598               pizda(1,1))
9599             vv(1)=pizda(1,1)-pizda(2,2)
9600             vv(2)=pizda(1,2)+pizda(2,1)
9601             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9602              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9603              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9604           enddo
9605         enddo
9606       enddo
9607 !      goto 1112
9608 !1111  continue
9609 ! Contribution from graph II
9610       call transpose2(EE(1,1,itk),auxmat(1,1))
9611       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9612       vv(1)=pizda(1,1)+pizda(2,2)
9613       vv(2)=pizda(2,1)-pizda(1,2)
9614       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9615        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9616 ! Explicit gradient in virtual-dihedral angles.
9617       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9618        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9619       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9620       vv(1)=pizda(1,1)+pizda(2,2)
9621       vv(2)=pizda(2,1)-pizda(1,2)
9622       if (l.eq.j+1) then
9623         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9624          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9625          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9626       else
9627         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9628          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9629          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9630       endif
9631 ! Cartesian gradient
9632       do iii=1,2
9633         do kkk=1,5
9634           do lll=1,3
9635             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9636               pizda(1,1))
9637             vv(1)=pizda(1,1)+pizda(2,2)
9638             vv(2)=pizda(2,1)-pizda(1,2)
9639             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9640              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9641              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9642           enddo
9643         enddo
9644       enddo
9645 !d      goto 1112
9646 !d1111  continue
9647       if (l.eq.j+1) then
9648 !d        goto 1110
9649 ! Parallel orientation
9650 ! Contribution from graph III
9651         call transpose2(EUg(1,1,l),auxmat(1,1))
9652         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9653         vv(1)=pizda(1,1)-pizda(2,2)
9654         vv(2)=pizda(1,2)+pizda(2,1)
9655         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9656          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9657 ! Explicit gradient in virtual-dihedral angles.
9658         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9659          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9660          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9661         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9662         vv(1)=pizda(1,1)-pizda(2,2)
9663         vv(2)=pizda(1,2)+pizda(2,1)
9664         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9665          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9666          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9667         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9668         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9669         vv(1)=pizda(1,1)-pizda(2,2)
9670         vv(2)=pizda(1,2)+pizda(2,1)
9671         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9672          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9673          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9674 ! Cartesian gradient
9675         do iii=1,2
9676           do kkk=1,5
9677             do lll=1,3
9678               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9679                 pizda(1,1))
9680               vv(1)=pizda(1,1)-pizda(2,2)
9681               vv(2)=pizda(1,2)+pizda(2,1)
9682               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9683                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9684                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9685             enddo
9686           enddo
9687         enddo
9688 !d        goto 1112
9689 ! Contribution from graph IV
9690 !d1110    continue
9691         call transpose2(EE(1,1,itl),auxmat(1,1))
9692         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9693         vv(1)=pizda(1,1)+pizda(2,2)
9694         vv(2)=pizda(2,1)-pizda(1,2)
9695         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9696          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9697 ! Explicit gradient in virtual-dihedral angles.
9698         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9699          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9700         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9701         vv(1)=pizda(1,1)+pizda(2,2)
9702         vv(2)=pizda(2,1)-pizda(1,2)
9703         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9704          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9705          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9706 ! Cartesian gradient
9707         do iii=1,2
9708           do kkk=1,5
9709             do lll=1,3
9710               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9711                 pizda(1,1))
9712               vv(1)=pizda(1,1)+pizda(2,2)
9713               vv(2)=pizda(2,1)-pizda(1,2)
9714               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9715                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9716                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9717             enddo
9718           enddo
9719         enddo
9720       else
9721 ! Antiparallel orientation
9722 ! Contribution from graph III
9723 !        goto 1110
9724         call transpose2(EUg(1,1,j),auxmat(1,1))
9725         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9726         vv(1)=pizda(1,1)-pizda(2,2)
9727         vv(2)=pizda(1,2)+pizda(2,1)
9728         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9729          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9730 ! Explicit gradient in virtual-dihedral angles.
9731         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9732          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9733          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9734         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9735         vv(1)=pizda(1,1)-pizda(2,2)
9736         vv(2)=pizda(1,2)+pizda(2,1)
9737         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9738          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9739          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9740         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9741         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9742         vv(1)=pizda(1,1)-pizda(2,2)
9743         vv(2)=pizda(1,2)+pizda(2,1)
9744         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9745          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9746          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9747 ! Cartesian gradient
9748         do iii=1,2
9749           do kkk=1,5
9750             do lll=1,3
9751               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9752                 pizda(1,1))
9753               vv(1)=pizda(1,1)-pizda(2,2)
9754               vv(2)=pizda(1,2)+pizda(2,1)
9755               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9756                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9757                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9758             enddo
9759           enddo
9760         enddo
9761 !d        goto 1112
9762 ! Contribution from graph IV
9763 1110    continue
9764         call transpose2(EE(1,1,itj),auxmat(1,1))
9765         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9766         vv(1)=pizda(1,1)+pizda(2,2)
9767         vv(2)=pizda(2,1)-pizda(1,2)
9768         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9769          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9770 ! Explicit gradient in virtual-dihedral angles.
9771         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9772          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9773         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9774         vv(1)=pizda(1,1)+pizda(2,2)
9775         vv(2)=pizda(2,1)-pizda(1,2)
9776         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9777          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9778          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9779 ! Cartesian gradient
9780         do iii=1,2
9781           do kkk=1,5
9782             do lll=1,3
9783               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9784                 pizda(1,1))
9785               vv(1)=pizda(1,1)+pizda(2,2)
9786               vv(2)=pizda(2,1)-pizda(1,2)
9787               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9788                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9789                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9790             enddo
9791           enddo
9792         enddo
9793       endif
9794 1112  continue
9795       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9796 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9797 !d        write (2,*) 'ijkl',i,j,k,l
9798 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9799 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9800 !d      endif
9801 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9802 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9803 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9804 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9805       if (j.lt.nres-1) then
9806         j1=j+1
9807         j2=j-1
9808       else
9809         j1=j-1
9810         j2=j-2
9811       endif
9812       if (l.lt.nres-1) then
9813         l1=l+1
9814         l2=l-1
9815       else
9816         l1=l-1
9817         l2=l-2
9818       endif
9819 !d      eij=1.0d0
9820 !d      ekl=1.0d0
9821 !d      ekont=1.0d0
9822 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9823 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9824 !        summed up outside the subrouine as for the other subroutines
9825 !        handling long-range interactions. The old code is commented out
9826 !        with "cgrad" to keep track of changes.
9827       do ll=1,3
9828 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9829 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9830         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9831         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9832 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9833 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9834 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9835 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9836 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9837 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9838 !     &   gradcorr5ij,
9839 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9840 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9841 !grad        ghalf=0.5d0*ggg1(ll)
9842 !d        ghalf=0.0d0
9843         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9844         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9845         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9846         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9847         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9848         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9849 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9850 !grad        ghalf=0.5d0*ggg2(ll)
9851         ghalf=0.0d0
9852         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9853         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9854         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9855         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9856         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9857         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9858       enddo
9859 !d      goto 1112
9860 !grad      do m=i+1,j-1
9861 !grad        do ll=1,3
9862 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9863 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9864 !grad        enddo
9865 !grad      enddo
9866 !grad      do m=k+1,l-1
9867 !grad        do ll=1,3
9868 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9869 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9870 !grad        enddo
9871 !grad      enddo
9872 !1112  continue
9873 !grad      do m=i+2,j2
9874 !grad        do ll=1,3
9875 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9876 !grad        enddo
9877 !grad      enddo
9878 !grad      do m=k+2,l2
9879 !grad        do ll=1,3
9880 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9881 !grad        enddo
9882 !grad      enddo
9883 !d      do iii=1,nres-3
9884 !d        write (2,*) iii,g_corr5_loc(iii)
9885 !d      enddo
9886       eello5=ekont*eel5
9887 !d      write (2,*) 'ekont',ekont
9888 !d      write (iout,*) 'eello5',ekont*eel5
9889       return
9890       end function eello5
9891 !-----------------------------------------------------------------------------
9892       real(kind=8) function eello6(i,j,k,l,jj,kk)
9893 !      implicit real*8 (a-h,o-z)
9894 !      include 'DIMENSIONS'
9895 !      include 'COMMON.IOUNITS'
9896 !      include 'COMMON.CHAIN'
9897 !      include 'COMMON.DERIV'
9898 !      include 'COMMON.INTERACT'
9899 !      include 'COMMON.CONTACTS'
9900 !      include 'COMMON.TORSION'
9901 !      include 'COMMON.VAR'
9902 !      include 'COMMON.GEO'
9903 !      include 'COMMON.FFIELD'
9904       real(kind=8),dimension(3) :: ggg1,ggg2
9905       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9906                    eello6_6,eel6
9907       real(kind=8) :: gradcorr6ij,gradcorr6kl
9908       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9909 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9910 !d        eello6=0.0d0
9911 !d        return
9912 !d      endif
9913 !d      write (iout,*)
9914 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9915 !d     &   ' and',k,l
9916       eello6_1=0.0d0
9917       eello6_2=0.0d0
9918       eello6_3=0.0d0
9919       eello6_4=0.0d0
9920       eello6_5=0.0d0
9921       eello6_6=0.0d0
9922 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9923 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9924       do iii=1,2
9925         do kkk=1,5
9926           do lll=1,3
9927             derx(lll,kkk,iii)=0.0d0
9928           enddo
9929         enddo
9930       enddo
9931 !d      eij=facont_hb(jj,i)
9932 !d      ekl=facont_hb(kk,k)
9933 !d      ekont=eij*ekl
9934 !d      eij=1.0d0
9935 !d      ekl=1.0d0
9936 !d      ekont=1.0d0
9937       if (l.eq.j+1) then
9938         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9939         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9940         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9941         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9942         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9943         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9944       else
9945         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9946         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9947         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9948         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9949         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9950           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9951         else
9952           eello6_5=0.0d0
9953         endif
9954         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9955       endif
9956 ! If turn contributions are considered, they will be handled separately.
9957       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9958 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9959 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9960 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9961 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9962 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9963 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9964 !d      goto 1112
9965       if (j.lt.nres-1) then
9966         j1=j+1
9967         j2=j-1
9968       else
9969         j1=j-1
9970         j2=j-2
9971       endif
9972       if (l.lt.nres-1) then
9973         l1=l+1
9974         l2=l-1
9975       else
9976         l1=l-1
9977         l2=l-2
9978       endif
9979       do ll=1,3
9980 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9981 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9982 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9983 !grad        ghalf=0.5d0*ggg1(ll)
9984 !d        ghalf=0.0d0
9985         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9986         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9987         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9988         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9989         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9990         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9991         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9992         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9993 !grad        ghalf=0.5d0*ggg2(ll)
9994 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9995 !d        ghalf=0.0d0
9996         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9997         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9998         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9999         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10000         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10001         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10002       enddo
10003 !d      goto 1112
10004 !grad      do m=i+1,j-1
10005 !grad        do ll=1,3
10006 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10007 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10008 !grad        enddo
10009 !grad      enddo
10010 !grad      do m=k+1,l-1
10011 !grad        do ll=1,3
10012 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10013 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10014 !grad        enddo
10015 !grad      enddo
10016 !grad1112  continue
10017 !grad      do m=i+2,j2
10018 !grad        do ll=1,3
10019 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10020 !grad        enddo
10021 !grad      enddo
10022 !grad      do m=k+2,l2
10023 !grad        do ll=1,3
10024 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10025 !grad        enddo
10026 !grad      enddo
10027 !d      do iii=1,nres-3
10028 !d        write (2,*) iii,g_corr6_loc(iii)
10029 !d      enddo
10030       eello6=ekont*eel6
10031 !d      write (2,*) 'ekont',ekont
10032 !d      write (iout,*) 'eello6',ekont*eel6
10033       return
10034       end function eello6
10035 !-----------------------------------------------------------------------------
10036       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10037       use comm_kut
10038 !      implicit real*8 (a-h,o-z)
10039 !      include 'DIMENSIONS'
10040 !      include 'COMMON.IOUNITS'
10041 !      include 'COMMON.CHAIN'
10042 !      include 'COMMON.DERIV'
10043 !      include 'COMMON.INTERACT'
10044 !      include 'COMMON.CONTACTS'
10045 !      include 'COMMON.TORSION'
10046 !      include 'COMMON.VAR'
10047 !      include 'COMMON.GEO'
10048       real(kind=8),dimension(2) :: vv,vv1
10049       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10050       logical :: swap
10051 !el      logical :: lprn
10052 !el      common /kutas/ lprn
10053       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10054       real(kind=8) :: s1,s2,s3,s4,s5
10055 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10056 !                                                                              C
10057 !      Parallel       Antiparallel                                             C
10058 !                                                                              C
10059 !          o             o                                                     C
10060 !         /l\           /j\                                                    C
10061 !        /   \         /   \                                                   C
10062 !       /| o |         | o |\                                                  C
10063 !     \ j|/k\|  /   \  |/k\|l /                                                C
10064 !      \ /   \ /     \ /   \ /                                                 C
10065 !       o     o       o     o                                                  C
10066 !       i             i                                                        C
10067 !                                                                              C
10068 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10069       itk=itortyp(itype(k,1))
10070       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10071       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10072       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10073       call transpose2(EUgC(1,1,k),auxmat(1,1))
10074       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10075       vv1(1)=pizda1(1,1)-pizda1(2,2)
10076       vv1(2)=pizda1(1,2)+pizda1(2,1)
10077       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10078       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10079       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10080       s5=scalar2(vv(1),Dtobr2(1,i))
10081 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10082       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10083       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10084        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10085        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10086        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10087        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10088        +scalar2(vv(1),Dtobr2der(1,i)))
10089       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10090       vv1(1)=pizda1(1,1)-pizda1(2,2)
10091       vv1(2)=pizda1(1,2)+pizda1(2,1)
10092       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10093       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10094       if (l.eq.j+1) then
10095         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10096        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10097        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10098        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10099        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10100       else
10101         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10102        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10103        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10104        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10105        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10106       endif
10107       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10108       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10109       vv1(1)=pizda1(1,1)-pizda1(2,2)
10110       vv1(2)=pizda1(1,2)+pizda1(2,1)
10111       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10112        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10113        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10114        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10115       do iii=1,2
10116         if (swap) then
10117           ind=3-iii
10118         else
10119           ind=iii
10120         endif
10121         do kkk=1,5
10122           do lll=1,3
10123             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10124             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10125             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10126             call transpose2(EUgC(1,1,k),auxmat(1,1))
10127             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10128               pizda1(1,1))
10129             vv1(1)=pizda1(1,1)-pizda1(2,2)
10130             vv1(2)=pizda1(1,2)+pizda1(2,1)
10131             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10132             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10133              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10134             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10135              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10136             s5=scalar2(vv(1),Dtobr2(1,i))
10137             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10138           enddo
10139         enddo
10140       enddo
10141       return
10142       end function eello6_graph1
10143 !-----------------------------------------------------------------------------
10144       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10145       use comm_kut
10146 !      implicit real*8 (a-h,o-z)
10147 !      include 'DIMENSIONS'
10148 !      include 'COMMON.IOUNITS'
10149 !      include 'COMMON.CHAIN'
10150 !      include 'COMMON.DERIV'
10151 !      include 'COMMON.INTERACT'
10152 !      include 'COMMON.CONTACTS'
10153 !      include 'COMMON.TORSION'
10154 !      include 'COMMON.VAR'
10155 !      include 'COMMON.GEO'
10156       logical :: swap
10157       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10158       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10159 !el      logical :: lprn
10160 !el      common /kutas/ lprn
10161       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10162       real(kind=8) :: s2,s3,s4
10163 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10164 !                                                                              C
10165 !      Parallel       Antiparallel                                             C
10166 !                                                                              C
10167 !          o             o                                                     C
10168 !     \   /l\           /j\   /                                                C
10169 !      \ /   \         /   \ /                                                 C
10170 !       o| o |         | o |o                                                  C
10171 !     \ j|/k\|      \  |/k\|l                                                  C
10172 !      \ /   \       \ /   \                                                   C
10173 !       o             o                                                        C
10174 !       i             i                                                        C
10175 !                                                                              C
10176 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10177 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10178 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10179 !           but not in a cluster cumulant
10180 #ifdef MOMENT
10181       s1=dip(1,jj,i)*dip(1,kk,k)
10182 #endif
10183       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10184       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10185       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10186       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10187       call transpose2(EUg(1,1,k),auxmat(1,1))
10188       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10189       vv(1)=pizda(1,1)-pizda(2,2)
10190       vv(2)=pizda(1,2)+pizda(2,1)
10191       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10192 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10193 #ifdef MOMENT
10194       eello6_graph2=-(s1+s2+s3+s4)
10195 #else
10196       eello6_graph2=-(s2+s3+s4)
10197 #endif
10198 !      eello6_graph2=-s3
10199 ! Derivatives in gamma(i-1)
10200       if (i.gt.1) then
10201 #ifdef MOMENT
10202         s1=dipderg(1,jj,i)*dip(1,kk,k)
10203 #endif
10204         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10205         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10206         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10207         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10208 #ifdef MOMENT
10209         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10210 #else
10211         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10212 #endif
10213 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10214       endif
10215 ! Derivatives in gamma(k-1)
10216 #ifdef MOMENT
10217       s1=dip(1,jj,i)*dipderg(1,kk,k)
10218 #endif
10219       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10220       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10221       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10222       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10223       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10224       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10225       vv(1)=pizda(1,1)-pizda(2,2)
10226       vv(2)=pizda(1,2)+pizda(2,1)
10227       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10228 #ifdef MOMENT
10229       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10230 #else
10231       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10232 #endif
10233 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10234 ! Derivatives in gamma(j-1) or gamma(l-1)
10235       if (j.gt.1) then
10236 #ifdef MOMENT
10237         s1=dipderg(3,jj,i)*dip(1,kk,k)
10238 #endif
10239         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10240         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10241         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10242         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10243         vv(1)=pizda(1,1)-pizda(2,2)
10244         vv(2)=pizda(1,2)+pizda(2,1)
10245         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10246 #ifdef MOMENT
10247         if (swap) then
10248           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10249         else
10250           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10251         endif
10252 #endif
10253         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10254 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10255       endif
10256 ! Derivatives in gamma(l-1) or gamma(j-1)
10257       if (l.gt.1) then
10258 #ifdef MOMENT
10259         s1=dip(1,jj,i)*dipderg(3,kk,k)
10260 #endif
10261         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10262         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10263         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10264         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10265         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10266         vv(1)=pizda(1,1)-pizda(2,2)
10267         vv(2)=pizda(1,2)+pizda(2,1)
10268         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10269 #ifdef MOMENT
10270         if (swap) then
10271           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10272         else
10273           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10274         endif
10275 #endif
10276         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10277 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10278       endif
10279 ! Cartesian derivatives.
10280       if (lprn) then
10281         write (2,*) 'In eello6_graph2'
10282         do iii=1,2
10283           write (2,*) 'iii=',iii
10284           do kkk=1,5
10285             write (2,*) 'kkk=',kkk
10286             do jjj=1,2
10287               write (2,'(3(2f10.5),5x)') &
10288               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10289             enddo
10290           enddo
10291         enddo
10292       endif
10293       do iii=1,2
10294         do kkk=1,5
10295           do lll=1,3
10296 #ifdef MOMENT
10297             if (iii.eq.1) then
10298               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10299             else
10300               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10301             endif
10302 #endif
10303             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10304               auxvec(1))
10305             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10306             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10307               auxvec(1))
10308             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10309             call transpose2(EUg(1,1,k),auxmat(1,1))
10310             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10311               pizda(1,1))
10312             vv(1)=pizda(1,1)-pizda(2,2)
10313             vv(2)=pizda(1,2)+pizda(2,1)
10314             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10315 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10316 #ifdef MOMENT
10317             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10318 #else
10319             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10320 #endif
10321             if (swap) then
10322               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10323             else
10324               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10325             endif
10326           enddo
10327         enddo
10328       enddo
10329       return
10330       end function eello6_graph2
10331 !-----------------------------------------------------------------------------
10332       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10333 !      implicit real*8 (a-h,o-z)
10334 !      include 'DIMENSIONS'
10335 !      include 'COMMON.IOUNITS'
10336 !      include 'COMMON.CHAIN'
10337 !      include 'COMMON.DERIV'
10338 !      include 'COMMON.INTERACT'
10339 !      include 'COMMON.CONTACTS'
10340 !      include 'COMMON.TORSION'
10341 !      include 'COMMON.VAR'
10342 !      include 'COMMON.GEO'
10343       real(kind=8),dimension(2) :: vv,auxvec
10344       real(kind=8),dimension(2,2) :: pizda,auxmat
10345       logical :: swap
10346       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10347       real(kind=8) :: s1,s2,s3,s4
10348 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10349 !                                                                              C
10350 !      Parallel       Antiparallel                                             C
10351 !                                                                              C
10352 !          o             o                                                     C
10353 !         /l\   /   \   /j\                                                    C
10354 !        /   \ /     \ /   \                                                   C
10355 !       /| o |o       o| o |\                                                  C
10356 !       j|/k\|  /      |/k\|l /                                                C
10357 !        /   \ /       /   \ /                                                 C
10358 !       /     o       /     o                                                  C
10359 !       i             i                                                        C
10360 !                                                                              C
10361 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10362 !
10363 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10364 !           energy moment and not to the cluster cumulant.
10365       iti=itortyp(itype(i,1))
10366       if (j.lt.nres-1) then
10367         itj1=itortyp(itype(j+1,1))
10368       else
10369         itj1=ntortyp+1
10370       endif
10371       itk=itortyp(itype(k,1))
10372       itk1=itortyp(itype(k+1,1))
10373       if (l.lt.nres-1) then
10374         itl1=itortyp(itype(l+1,1))
10375       else
10376         itl1=ntortyp+1
10377       endif
10378 #ifdef MOMENT
10379       s1=dip(4,jj,i)*dip(4,kk,k)
10380 #endif
10381       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10382       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10383       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10384       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10385       call transpose2(EE(1,1,itk),auxmat(1,1))
10386       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10387       vv(1)=pizda(1,1)+pizda(2,2)
10388       vv(2)=pizda(2,1)-pizda(1,2)
10389       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10390 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10391 !d     & "sum",-(s2+s3+s4)
10392 #ifdef MOMENT
10393       eello6_graph3=-(s1+s2+s3+s4)
10394 #else
10395       eello6_graph3=-(s2+s3+s4)
10396 #endif
10397 !      eello6_graph3=-s4
10398 ! Derivatives in gamma(k-1)
10399       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10400       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10401       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10402       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10403 ! Derivatives in gamma(l-1)
10404       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10405       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10406       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10407       vv(1)=pizda(1,1)+pizda(2,2)
10408       vv(2)=pizda(2,1)-pizda(1,2)
10409       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10410       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10411 ! Cartesian derivatives.
10412       do iii=1,2
10413         do kkk=1,5
10414           do lll=1,3
10415 #ifdef MOMENT
10416             if (iii.eq.1) then
10417               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10418             else
10419               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10420             endif
10421 #endif
10422             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10423               auxvec(1))
10424             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10425             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10426               auxvec(1))
10427             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10428             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10429               pizda(1,1))
10430             vv(1)=pizda(1,1)+pizda(2,2)
10431             vv(2)=pizda(2,1)-pizda(1,2)
10432             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10433 #ifdef MOMENT
10434             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10435 #else
10436             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10437 #endif
10438             if (swap) then
10439               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10440             else
10441               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10442             endif
10443 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10444           enddo
10445         enddo
10446       enddo
10447       return
10448       end function eello6_graph3
10449 !-----------------------------------------------------------------------------
10450       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10451 !      implicit real*8 (a-h,o-z)
10452 !      include 'DIMENSIONS'
10453 !      include 'COMMON.IOUNITS'
10454 !      include 'COMMON.CHAIN'
10455 !      include 'COMMON.DERIV'
10456 !      include 'COMMON.INTERACT'
10457 !      include 'COMMON.CONTACTS'
10458 !      include 'COMMON.TORSION'
10459 !      include 'COMMON.VAR'
10460 !      include 'COMMON.GEO'
10461 !      include 'COMMON.FFIELD'
10462       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10463       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10464       logical :: swap
10465       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10466               iii,kkk,lll
10467       real(kind=8) :: s1,s2,s3,s4
10468 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10469 !                                                                              C
10470 !      Parallel       Antiparallel                                             C
10471 !                                                                              C
10472 !          o             o                                                     C
10473 !         /l\   /   \   /j\                                                    C
10474 !        /   \ /     \ /   \                                                   C
10475 !       /| o |o       o| o |\                                                  C
10476 !     \ j|/k\|      \  |/k\|l                                                  C
10477 !      \ /   \       \ /   \                                                   C
10478 !       o     \       o     \                                                  C
10479 !       i             i                                                        C
10480 !                                                                              C
10481 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10482 !
10483 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10484 !           energy moment and not to the cluster cumulant.
10485 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10486       iti=itortyp(itype(i,1))
10487       itj=itortyp(itype(j,1))
10488       if (j.lt.nres-1) then
10489         itj1=itortyp(itype(j+1,1))
10490       else
10491         itj1=ntortyp+1
10492       endif
10493       itk=itortyp(itype(k,1))
10494       if (k.lt.nres-1) then
10495         itk1=itortyp(itype(k+1,1))
10496       else
10497         itk1=ntortyp+1
10498       endif
10499       itl=itortyp(itype(l,1))
10500       if (l.lt.nres-1) then
10501         itl1=itortyp(itype(l+1,1))
10502       else
10503         itl1=ntortyp+1
10504       endif
10505 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10506 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10507 !d     & ' itl',itl,' itl1',itl1
10508 #ifdef MOMENT
10509       if (imat.eq.1) then
10510         s1=dip(3,jj,i)*dip(3,kk,k)
10511       else
10512         s1=dip(2,jj,j)*dip(2,kk,l)
10513       endif
10514 #endif
10515       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10516       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10517       if (j.eq.l+1) then
10518         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10519         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10520       else
10521         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10522         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10523       endif
10524       call transpose2(EUg(1,1,k),auxmat(1,1))
10525       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10526       vv(1)=pizda(1,1)-pizda(2,2)
10527       vv(2)=pizda(2,1)+pizda(1,2)
10528       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10529 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10530 #ifdef MOMENT
10531       eello6_graph4=-(s1+s2+s3+s4)
10532 #else
10533       eello6_graph4=-(s2+s3+s4)
10534 #endif
10535 ! Derivatives in gamma(i-1)
10536       if (i.gt.1) then
10537 #ifdef MOMENT
10538         if (imat.eq.1) then
10539           s1=dipderg(2,jj,i)*dip(3,kk,k)
10540         else
10541           s1=dipderg(4,jj,j)*dip(2,kk,l)
10542         endif
10543 #endif
10544         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10545         if (j.eq.l+1) then
10546           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10547           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10548         else
10549           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10550           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10551         endif
10552         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10553         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10554 !d          write (2,*) 'turn6 derivatives'
10555 #ifdef MOMENT
10556           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10557 #else
10558           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10559 #endif
10560         else
10561 #ifdef MOMENT
10562           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10563 #else
10564           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10565 #endif
10566         endif
10567       endif
10568 ! Derivatives in gamma(k-1)
10569 #ifdef MOMENT
10570       if (imat.eq.1) then
10571         s1=dip(3,jj,i)*dipderg(2,kk,k)
10572       else
10573         s1=dip(2,jj,j)*dipderg(4,kk,l)
10574       endif
10575 #endif
10576       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10577       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10578       if (j.eq.l+1) then
10579         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10580         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10581       else
10582         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10583         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10584       endif
10585       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10586       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10587       vv(1)=pizda(1,1)-pizda(2,2)
10588       vv(2)=pizda(2,1)+pizda(1,2)
10589       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10590       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10591 #ifdef MOMENT
10592         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10593 #else
10594         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10595 #endif
10596       else
10597 #ifdef MOMENT
10598         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10599 #else
10600         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10601 #endif
10602       endif
10603 ! Derivatives in gamma(j-1) or gamma(l-1)
10604       if (l.eq.j+1 .and. l.gt.1) then
10605         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10606         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10607         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10608         vv(1)=pizda(1,1)-pizda(2,2)
10609         vv(2)=pizda(2,1)+pizda(1,2)
10610         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10611         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10612       else if (j.gt.1) then
10613         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10614         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10615         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10616         vv(1)=pizda(1,1)-pizda(2,2)
10617         vv(2)=pizda(2,1)+pizda(1,2)
10618         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10619         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10620           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10621         else
10622           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10623         endif
10624       endif
10625 ! Cartesian derivatives.
10626       do iii=1,2
10627         do kkk=1,5
10628           do lll=1,3
10629 #ifdef MOMENT
10630             if (iii.eq.1) then
10631               if (imat.eq.1) then
10632                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10633               else
10634                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10635               endif
10636             else
10637               if (imat.eq.1) then
10638                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10639               else
10640                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10641               endif
10642             endif
10643 #endif
10644             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10645               auxvec(1))
10646             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10647             if (j.eq.l+1) then
10648               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10649                 b1(1,itj1),auxvec(1))
10650               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10651             else
10652               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10653                 b1(1,itl1),auxvec(1))
10654               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10655             endif
10656             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10657               pizda(1,1))
10658             vv(1)=pizda(1,1)-pizda(2,2)
10659             vv(2)=pizda(2,1)+pizda(1,2)
10660             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10661             if (swap) then
10662               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10663 #ifdef MOMENT
10664                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10665                    -(s1+s2+s4)
10666 #else
10667                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10668                    -(s2+s4)
10669 #endif
10670                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10671               else
10672 #ifdef MOMENT
10673                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10674 #else
10675                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10676 #endif
10677                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10678               endif
10679             else
10680 #ifdef MOMENT
10681               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10682 #else
10683               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10684 #endif
10685               if (l.eq.j+1) then
10686                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10687               else
10688                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10689               endif
10690             endif
10691           enddo
10692         enddo
10693       enddo
10694       return
10695       end function eello6_graph4
10696 !-----------------------------------------------------------------------------
10697       real(kind=8) function eello_turn6(i,jj,kk)
10698 !      implicit real*8 (a-h,o-z)
10699 !      include 'DIMENSIONS'
10700 !      include 'COMMON.IOUNITS'
10701 !      include 'COMMON.CHAIN'
10702 !      include 'COMMON.DERIV'
10703 !      include 'COMMON.INTERACT'
10704 !      include 'COMMON.CONTACTS'
10705 !      include 'COMMON.TORSION'
10706 !      include 'COMMON.VAR'
10707 !      include 'COMMON.GEO'
10708       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10709       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10710       real(kind=8),dimension(3) :: ggg1,ggg2
10711       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10712       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10713 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10714 !           the respective energy moment and not to the cluster cumulant.
10715 !el local variables
10716       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10717       integer :: j1,j2,l1,l2,ll
10718       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10719       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10720       s1=0.0d0
10721       s8=0.0d0
10722       s13=0.0d0
10723 !
10724       eello_turn6=0.0d0
10725       j=i+4
10726       k=i+1
10727       l=i+3
10728       iti=itortyp(itype(i,1))
10729       itk=itortyp(itype(k,1))
10730       itk1=itortyp(itype(k+1,1))
10731       itl=itortyp(itype(l,1))
10732       itj=itortyp(itype(j,1))
10733 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10734 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10735 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10736 !d        eello6=0.0d0
10737 !d        return
10738 !d      endif
10739 !d      write (iout,*)
10740 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10741 !d     &   ' and',k,l
10742 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10743       do iii=1,2
10744         do kkk=1,5
10745           do lll=1,3
10746             derx_turn(lll,kkk,iii)=0.0d0
10747           enddo
10748         enddo
10749       enddo
10750 !d      eij=1.0d0
10751 !d      ekl=1.0d0
10752 !d      ekont=1.0d0
10753       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10754 !d      eello6_5=0.0d0
10755 !d      write (2,*) 'eello6_5',eello6_5
10756 #ifdef MOMENT
10757       call transpose2(AEA(1,1,1),auxmat(1,1))
10758       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10759       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10760       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10761 #endif
10762       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10763       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10764       s2 = scalar2(b1(1,itk),vtemp1(1))
10765 #ifdef MOMENT
10766       call transpose2(AEA(1,1,2),atemp(1,1))
10767       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10768       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10769       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10770 #endif
10771       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10772       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10773       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10774 #ifdef MOMENT
10775       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10776       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10777       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10778       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10779       ss13 = scalar2(b1(1,itk),vtemp4(1))
10780       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10781 #endif
10782 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10783 !      s1=0.0d0
10784 !      s2=0.0d0
10785 !      s8=0.0d0
10786 !      s12=0.0d0
10787 !      s13=0.0d0
10788       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10789 ! Derivatives in gamma(i+2)
10790       s1d =0.0d0
10791       s8d =0.0d0
10792 #ifdef MOMENT
10793       call transpose2(AEA(1,1,1),auxmatd(1,1))
10794       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10795       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10796       call transpose2(AEAderg(1,1,2),atempd(1,1))
10797       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10798       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10799 #endif
10800       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10801       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10802       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10803 !      s1d=0.0d0
10804 !      s2d=0.0d0
10805 !      s8d=0.0d0
10806 !      s12d=0.0d0
10807 !      s13d=0.0d0
10808       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10809 ! Derivatives in gamma(i+3)
10810 #ifdef MOMENT
10811       call transpose2(AEA(1,1,1),auxmatd(1,1))
10812       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10813       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10814       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10815 #endif
10816       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10817       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10818       s2d = scalar2(b1(1,itk),vtemp1d(1))
10819 #ifdef MOMENT
10820       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10821       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10822 #endif
10823       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10824 #ifdef MOMENT
10825       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10826       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10827       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10828 #endif
10829 !      s1d=0.0d0
10830 !      s2d=0.0d0
10831 !      s8d=0.0d0
10832 !      s12d=0.0d0
10833 !      s13d=0.0d0
10834 #ifdef MOMENT
10835       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10836                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10837 #else
10838       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10839                     -0.5d0*ekont*(s2d+s12d)
10840 #endif
10841 ! Derivatives in gamma(i+4)
10842       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10843       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10844       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10845 #ifdef MOMENT
10846       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10847       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10848       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10849 #endif
10850 !      s1d=0.0d0
10851 !      s2d=0.0d0
10852 !      s8d=0.0d0
10853 !      s12d=0.0d0
10854 !      s13d=0.0d0
10855 #ifdef MOMENT
10856       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10857 #else
10858       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10859 #endif
10860 ! Derivatives in gamma(i+5)
10861 #ifdef MOMENT
10862       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10863       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10864       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10865 #endif
10866       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10867       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10868       s2d = scalar2(b1(1,itk),vtemp1d(1))
10869 #ifdef MOMENT
10870       call transpose2(AEA(1,1,2),atempd(1,1))
10871       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10872       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10873 #endif
10874       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10875       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10876 #ifdef MOMENT
10877       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10878       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10879       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10880 #endif
10881 !      s1d=0.0d0
10882 !      s2d=0.0d0
10883 !      s8d=0.0d0
10884 !      s12d=0.0d0
10885 !      s13d=0.0d0
10886 #ifdef MOMENT
10887       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10888                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10889 #else
10890       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10891                     -0.5d0*ekont*(s2d+s12d)
10892 #endif
10893 ! Cartesian derivatives
10894       do iii=1,2
10895         do kkk=1,5
10896           do lll=1,3
10897 #ifdef MOMENT
10898             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10899             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10900             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10901 #endif
10902             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10903             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10904                 vtemp1d(1))
10905             s2d = scalar2(b1(1,itk),vtemp1d(1))
10906 #ifdef MOMENT
10907             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10908             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10909             s8d = -(atempd(1,1)+atempd(2,2))* &
10910                  scalar2(cc(1,1,itl),vtemp2(1))
10911 #endif
10912             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10913                  auxmatd(1,1))
10914             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10915             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10916 !      s1d=0.0d0
10917 !      s2d=0.0d0
10918 !      s8d=0.0d0
10919 !      s12d=0.0d0
10920 !      s13d=0.0d0
10921 #ifdef MOMENT
10922             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10923               - 0.5d0*(s1d+s2d)
10924 #else
10925             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10926               - 0.5d0*s2d
10927 #endif
10928 #ifdef MOMENT
10929             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10930               - 0.5d0*(s8d+s12d)
10931 #else
10932             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10933               - 0.5d0*s12d
10934 #endif
10935           enddo
10936         enddo
10937       enddo
10938 #ifdef MOMENT
10939       do kkk=1,5
10940         do lll=1,3
10941           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10942             achuj_tempd(1,1))
10943           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10944           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10945           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10946           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10947           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10948             vtemp4d(1))
10949           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10950           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10951           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10952         enddo
10953       enddo
10954 #endif
10955 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10956 !d     &  16*eel_turn6_num
10957 !d      goto 1112
10958       if (j.lt.nres-1) then
10959         j1=j+1
10960         j2=j-1
10961       else
10962         j1=j-1
10963         j2=j-2
10964       endif
10965       if (l.lt.nres-1) then
10966         l1=l+1
10967         l2=l-1
10968       else
10969         l1=l-1
10970         l2=l-2
10971       endif
10972       do ll=1,3
10973 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10974 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10975 !grad        ghalf=0.5d0*ggg1(ll)
10976 !d        ghalf=0.0d0
10977         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10978         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10979         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10980           +ekont*derx_turn(ll,2,1)
10981         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10982         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10983           +ekont*derx_turn(ll,4,1)
10984         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10985         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10986         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10987 !grad        ghalf=0.5d0*ggg2(ll)
10988 !d        ghalf=0.0d0
10989         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10990           +ekont*derx_turn(ll,2,2)
10991         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10992         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10993           +ekont*derx_turn(ll,4,2)
10994         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10995         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10996         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10997       enddo
10998 !d      goto 1112
10999 !grad      do m=i+1,j-1
11000 !grad        do ll=1,3
11001 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11002 !grad        enddo
11003 !grad      enddo
11004 !grad      do m=k+1,l-1
11005 !grad        do ll=1,3
11006 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11007 !grad        enddo
11008 !grad      enddo
11009 !grad1112  continue
11010 !grad      do m=i+2,j2
11011 !grad        do ll=1,3
11012 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11013 !grad        enddo
11014 !grad      enddo
11015 !grad      do m=k+2,l2
11016 !grad        do ll=1,3
11017 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11018 !grad        enddo
11019 !grad      enddo
11020 !d      do iii=1,nres-3
11021 !d        write (2,*) iii,g_corr6_loc(iii)
11022 !d      enddo
11023       eello_turn6=ekont*eel_turn6
11024 !d      write (2,*) 'ekont',ekont
11025 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11026       return
11027       end function eello_turn6
11028 !-----------------------------------------------------------------------------
11029       subroutine MATVEC2(A1,V1,V2)
11030 !DIR$ INLINEALWAYS MATVEC2
11031 #ifndef OSF
11032 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11033 #endif
11034 !      implicit real*8 (a-h,o-z)
11035 !      include 'DIMENSIONS'
11036       real(kind=8),dimension(2) :: V1,V2
11037       real(kind=8),dimension(2,2) :: A1
11038       real(kind=8) :: vaux1,vaux2
11039 !      DO 1 I=1,2
11040 !        VI=0.0
11041 !        DO 3 K=1,2
11042 !    3     VI=VI+A1(I,K)*V1(K)
11043 !        Vaux(I)=VI
11044 !    1 CONTINUE
11045
11046       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11047       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11048
11049       v2(1)=vaux1
11050       v2(2)=vaux2
11051       end subroutine MATVEC2
11052 !-----------------------------------------------------------------------------
11053       subroutine MATMAT2(A1,A2,A3)
11054 #ifndef OSF
11055 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11056 #endif
11057 !      implicit real*8 (a-h,o-z)
11058 !      include 'DIMENSIONS'
11059       real(kind=8),dimension(2,2) :: A1,A2,A3
11060       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11061 !      DIMENSION AI3(2,2)
11062 !        DO  J=1,2
11063 !          A3IJ=0.0
11064 !          DO K=1,2
11065 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11066 !          enddo
11067 !          A3(I,J)=A3IJ
11068 !       enddo
11069 !      enddo
11070
11071       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11072       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11073       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11074       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11075
11076       A3(1,1)=AI3_11
11077       A3(2,1)=AI3_21
11078       A3(1,2)=AI3_12
11079       A3(2,2)=AI3_22
11080       end subroutine MATMAT2
11081 !-----------------------------------------------------------------------------
11082       real(kind=8) function scalar2(u,v)
11083 !DIR$ INLINEALWAYS scalar2
11084       implicit none
11085       real(kind=8),dimension(2) :: u,v
11086       real(kind=8) :: sc
11087       integer :: i
11088       scalar2=u(1)*v(1)+u(2)*v(2)
11089       return
11090       end function scalar2
11091 !-----------------------------------------------------------------------------
11092       subroutine transpose2(a,at)
11093 !DIR$ INLINEALWAYS transpose2
11094 #ifndef OSF
11095 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11096 #endif
11097       implicit none
11098       real(kind=8),dimension(2,2) :: a,at
11099       at(1,1)=a(1,1)
11100       at(1,2)=a(2,1)
11101       at(2,1)=a(1,2)
11102       at(2,2)=a(2,2)
11103       return
11104       end subroutine transpose2
11105 !-----------------------------------------------------------------------------
11106       subroutine transpose(n,a,at)
11107       implicit none
11108       integer :: n,i,j
11109       real(kind=8),dimension(n,n) :: a,at
11110       do i=1,n
11111         do j=1,n
11112           at(j,i)=a(i,j)
11113         enddo
11114       enddo
11115       return
11116       end subroutine transpose
11117 !-----------------------------------------------------------------------------
11118       subroutine prodmat3(a1,a2,kk,transp,prod)
11119 !DIR$ INLINEALWAYS prodmat3
11120 #ifndef OSF
11121 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11122 #endif
11123       implicit none
11124       integer :: i,j
11125       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11126       logical :: transp
11127 !rc      double precision auxmat(2,2),prod_(2,2)
11128
11129       if (transp) then
11130 !rc        call transpose2(kk(1,1),auxmat(1,1))
11131 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11132 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11133
11134            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11135        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11136            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11137        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11138            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11139        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11140            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11141        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11142
11143       else
11144 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11145 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11146
11147            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11148         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11149            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11150         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11151            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11152         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11153            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11154         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11155
11156       endif
11157 !      call transpose2(a2(1,1),a2t(1,1))
11158
11159 !rc      print *,transp
11160 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11161 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11162
11163       return
11164       end subroutine prodmat3
11165 !-----------------------------------------------------------------------------
11166 ! energy_p_new_barrier.F
11167 !-----------------------------------------------------------------------------
11168       subroutine sum_gradient
11169 !      implicit real*8 (a-h,o-z)
11170       use io_base, only: pdbout
11171 !      include 'DIMENSIONS'
11172 #ifndef ISNAN
11173       external proc_proc
11174 #ifdef WINPGI
11175 !MS$ATTRIBUTES C ::  proc_proc
11176 #endif
11177 #endif
11178 #ifdef MPI
11179       include 'mpif.h'
11180 #endif
11181       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11182                    gloc_scbuf !(3,maxres)
11183
11184       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11185 !#endif
11186 !el local variables
11187       integer :: i,j,k,ierror,ierr
11188       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11189                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11190                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11191                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11192                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11193                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11194                    gsccorr_max,gsccorrx_max,time00
11195
11196 !      include 'COMMON.SETUP'
11197 !      include 'COMMON.IOUNITS'
11198 !      include 'COMMON.FFIELD'
11199 !      include 'COMMON.DERIV'
11200 !      include 'COMMON.INTERACT'
11201 !      include 'COMMON.SBRIDGE'
11202 !      include 'COMMON.CHAIN'
11203 !      include 'COMMON.VAR'
11204 !      include 'COMMON.CONTROL'
11205 !      include 'COMMON.TIME1'
11206 !      include 'COMMON.MAXGRAD'
11207 !      include 'COMMON.SCCOR'
11208 #ifdef TIMING
11209       time01=MPI_Wtime()
11210 #endif
11211 !#define DEBUG
11212 #ifdef DEBUG
11213       write (iout,*) "sum_gradient gvdwc, gvdwx"
11214       do i=1,nres
11215         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11216          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11217       enddo
11218       call flush(iout)
11219 #endif
11220 #ifdef MPI
11221         gradbufc=0.0d0
11222         gradbufx=0.0d0
11223         gradbufc_sum=0.0d0
11224         gloc_scbuf=0.0d0
11225         glocbuf=0.0d0
11226 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11227         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11228           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11229 #endif
11230 !
11231 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11232 !            in virtual-bond-vector coordinates
11233 !
11234 #ifdef DEBUG
11235 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11236 !      do i=1,nres-1
11237 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11238 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11239 !      enddo
11240 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11241 !      do i=1,nres-1
11242 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11243 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11244 !      enddo
11245 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11246 !      do i=1,nres
11247 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11248 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11249 !         (gvdwc_scpp(j,i),j=1,3)
11250 !      enddo
11251 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11252 !      do i=1,nres
11253 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11254 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11255 !         (gelc_loc_long(j,i),j=1,3)
11256 !      enddo
11257       call flush(iout)
11258 #endif
11259 #ifdef SPLITELE
11260       do i=0,nct
11261         do j=1,3
11262           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11263                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11264                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11265                       wel_loc*gel_loc_long(j,i)+ &
11266                       wcorr*gradcorr_long(j,i)+ &
11267                       wcorr5*gradcorr5_long(j,i)+ &
11268                       wcorr6*gradcorr6_long(j,i)+ &
11269                       wturn6*gcorr6_turn_long(j,i)+ &
11270                       wstrain*ghpbc(j,i) &
11271                      +wliptran*gliptranc(j,i) &
11272                      +gradafm(j,i) &
11273                      +welec*gshieldc(j,i) &
11274                      +wcorr*gshieldc_ec(j,i) &
11275                      +wturn3*gshieldc_t3(j,i)&
11276                      +wturn4*gshieldc_t4(j,i)&
11277                      +wel_loc*gshieldc_ll(j,i)&
11278                      +wtube*gg_tube(j,i) &
11279                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11280                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11281                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11282                      wcorr_nucl*gradcorr_nucl(j,i)&
11283                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11284                      wcatprot* gradpepcat(j,i)+ &
11285                      wcatcat*gradcatcat(j,i)+   &
11286                      wscbase*gvdwc_scbase(j,i)+ &
11287                      wpepbase*gvdwc_pepbase(j,i)+&
11288                      wscpho*gvdwc_scpho(j,i)+   &
11289                      wpeppho*gvdwc_peppho(j,i)
11290
11291
11292
11293
11294
11295         enddo
11296       enddo
11297 #else
11298       do i=0,nct
11299         do j=1,3
11300           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11301                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11302                       welec*gelc_long(j,i)+ &
11303                       wbond*gradb(j,i)+ &
11304                       wel_loc*gel_loc_long(j,i)+ &
11305                       wcorr*gradcorr_long(j,i)+ &
11306                       wcorr5*gradcorr5_long(j,i)+ &
11307                       wcorr6*gradcorr6_long(j,i)+ &
11308                       wturn6*gcorr6_turn_long(j,i)+ &
11309                       wstrain*ghpbc(j,i) &
11310                      +wliptran*gliptranc(j,i) &
11311                      +gradafm(j,i) &
11312                      +welec*gshieldc(j,i)&
11313                      +wcorr*gshieldc_ec(j,i) &
11314                      +wturn4*gshieldc_t4(j,i) &
11315                      +wel_loc*gshieldc_ll(j,i)&
11316                      +wtube*gg_tube(j,i) &
11317                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11318                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11319                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11320                      wcorr_nucl*gradcorr_nucl(j,i) &
11321                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11322                      wcatprot* gradpepcat(j,i)+ &
11323                      wcatcat*gradcatcat(j,i)+   &
11324                      wscbase*gvdwc_scbase(j,i)  &
11325                      wpepbase*gvdwc_pepbase(j,i)+&
11326                      wscpho*gvdwc_scpho(j,i)+&
11327                      wpeppho*gvdwc_peppho(j,i)
11328
11329
11330         enddo
11331       enddo
11332 #endif
11333 #ifdef MPI
11334       if (nfgtasks.gt.1) then
11335       time00=MPI_Wtime()
11336 #ifdef DEBUG
11337       write (iout,*) "gradbufc before allreduce"
11338       do i=1,nres
11339         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11340       enddo
11341       call flush(iout)
11342 #endif
11343       do i=0,nres
11344         do j=1,3
11345           gradbufc_sum(j,i)=gradbufc(j,i)
11346         enddo
11347       enddo
11348 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11349 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11350 !      time_reduce=time_reduce+MPI_Wtime()-time00
11351 #ifdef DEBUG
11352 !      write (iout,*) "gradbufc_sum after allreduce"
11353 !      do i=1,nres
11354 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11355 !      enddo
11356 !      call flush(iout)
11357 #endif
11358 #ifdef TIMING
11359 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11360 #endif
11361       do i=0,nres
11362         do k=1,3
11363           gradbufc(k,i)=0.0d0
11364         enddo
11365       enddo
11366 #ifdef DEBUG
11367       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11368       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11369                         " jgrad_end  ",jgrad_end(i),&
11370                         i=igrad_start,igrad_end)
11371 #endif
11372 !
11373 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11374 ! do not parallelize this part.
11375 !
11376 !      do i=igrad_start,igrad_end
11377 !        do j=jgrad_start(i),jgrad_end(i)
11378 !          do k=1,3
11379 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11380 !          enddo
11381 !        enddo
11382 !      enddo
11383       do j=1,3
11384         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11385       enddo
11386       do i=nres-2,-1,-1
11387         do j=1,3
11388           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11389         enddo
11390       enddo
11391 #ifdef DEBUG
11392       write (iout,*) "gradbufc after summing"
11393       do i=1,nres
11394         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11395       enddo
11396       call flush(iout)
11397 #endif
11398       else
11399 #endif
11400 !el#define DEBUG
11401 #ifdef DEBUG
11402       write (iout,*) "gradbufc"
11403       do i=1,nres
11404         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11405       enddo
11406       call flush(iout)
11407 #endif
11408 !el#undef DEBUG
11409       do i=-1,nres
11410         do j=1,3
11411           gradbufc_sum(j,i)=gradbufc(j,i)
11412           gradbufc(j,i)=0.0d0
11413         enddo
11414       enddo
11415       do j=1,3
11416         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11417       enddo
11418       do i=nres-2,-1,-1
11419         do j=1,3
11420           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11421         enddo
11422       enddo
11423 !      do i=nnt,nres-1
11424 !        do k=1,3
11425 !          gradbufc(k,i)=0.0d0
11426 !        enddo
11427 !        do j=i+1,nres
11428 !          do k=1,3
11429 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11430 !          enddo
11431 !        enddo
11432 !      enddo
11433 !el#define DEBUG
11434 #ifdef DEBUG
11435       write (iout,*) "gradbufc after summing"
11436       do i=1,nres
11437         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11438       enddo
11439       call flush(iout)
11440 #endif
11441 !el#undef DEBUG
11442 #ifdef MPI
11443       endif
11444 #endif
11445       do k=1,3
11446         gradbufc(k,nres)=0.0d0
11447       enddo
11448 !el----------------
11449 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11450 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11451 !el-----------------
11452       do i=-1,nct
11453         do j=1,3
11454 #ifdef SPLITELE
11455           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11456                       wel_loc*gel_loc(j,i)+ &
11457                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11458                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11459                       wel_loc*gel_loc_long(j,i)+ &
11460                       wcorr*gradcorr_long(j,i)+ &
11461                       wcorr5*gradcorr5_long(j,i)+ &
11462                       wcorr6*gradcorr6_long(j,i)+ &
11463                       wturn6*gcorr6_turn_long(j,i))+ &
11464                       wbond*gradb(j,i)+ &
11465                       wcorr*gradcorr(j,i)+ &
11466                       wturn3*gcorr3_turn(j,i)+ &
11467                       wturn4*gcorr4_turn(j,i)+ &
11468                       wcorr5*gradcorr5(j,i)+ &
11469                       wcorr6*gradcorr6(j,i)+ &
11470                       wturn6*gcorr6_turn(j,i)+ &
11471                       wsccor*gsccorc(j,i) &
11472                      +wscloc*gscloc(j,i)  &
11473                      +wliptran*gliptranc(j,i) &
11474                      +gradafm(j,i) &
11475                      +welec*gshieldc(j,i) &
11476                      +welec*gshieldc_loc(j,i) &
11477                      +wcorr*gshieldc_ec(j,i) &
11478                      +wcorr*gshieldc_loc_ec(j,i) &
11479                      +wturn3*gshieldc_t3(j,i) &
11480                      +wturn3*gshieldc_loc_t3(j,i) &
11481                      +wturn4*gshieldc_t4(j,i) &
11482                      +wturn4*gshieldc_loc_t4(j,i) &
11483                      +wel_loc*gshieldc_ll(j,i) &
11484                      +wel_loc*gshieldc_loc_ll(j,i) &
11485                      +wtube*gg_tube(j,i) &
11486                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11487                      +wvdwpsb*gvdwpsb1(j,i))&
11488                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11489 !                      if (i.eq.21) then
11490 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11491 !                      wturn4*gshieldc_t4(j,i), &
11492 !                     wturn4*gshieldc_loc_t4(j,i)
11493 !                       endif
11494 !                 if ((i.le.2).and.(i.ge.1))
11495 !                       print *,gradc(j,i,icg),&
11496 !                      gradbufc(j,i),welec*gelc(j,i), &
11497 !                      wel_loc*gel_loc(j,i), &
11498 !                      wscp*gvdwc_scpp(j,i), &
11499 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11500 !                      wel_loc*gel_loc_long(j,i), &
11501 !                      wcorr*gradcorr_long(j,i), &
11502 !                      wcorr5*gradcorr5_long(j,i), &
11503 !                      wcorr6*gradcorr6_long(j,i), &
11504 !                      wturn6*gcorr6_turn_long(j,i), &
11505 !                      wbond*gradb(j,i), &
11506 !                      wcorr*gradcorr(j,i), &
11507 !                      wturn3*gcorr3_turn(j,i), &
11508 !                      wturn4*gcorr4_turn(j,i), &
11509 !                      wcorr5*gradcorr5(j,i), &
11510 !                      wcorr6*gradcorr6(j,i), &
11511 !                      wturn6*gcorr6_turn(j,i), &
11512 !                      wsccor*gsccorc(j,i) &
11513 !                     ,wscloc*gscloc(j,i)  &
11514 !                     ,wliptran*gliptranc(j,i) &
11515 !                    ,gradafm(j,i) &
11516 !                     ,welec*gshieldc(j,i) &
11517 !                     ,welec*gshieldc_loc(j,i) &
11518 !                     ,wcorr*gshieldc_ec(j,i) &
11519 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11520 !                     ,wturn3*gshieldc_t3(j,i) &
11521 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11522 !                     ,wturn4*gshieldc_t4(j,i) &
11523 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11524 !                     ,wel_loc*gshieldc_ll(j,i) &
11525 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11526 !                     ,wtube*gg_tube(j,i) &
11527 !                     ,wbond_nucl*gradb_nucl(j,i) &
11528 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11529 !                     wvdwpsb*gvdwpsb1(j,i)&
11530 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11531 !
11532
11533 #else
11534           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11535                       wel_loc*gel_loc(j,i)+ &
11536                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11537                       welec*gelc_long(j,i)+ &
11538                       wel_loc*gel_loc_long(j,i)+ &
11539 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11540                       wcorr5*gradcorr5_long(j,i)+ &
11541                       wcorr6*gradcorr6_long(j,i)+ &
11542                       wturn6*gcorr6_turn_long(j,i))+ &
11543                       wbond*gradb(j,i)+ &
11544                       wcorr*gradcorr(j,i)+ &
11545                       wturn3*gcorr3_turn(j,i)+ &
11546                       wturn4*gcorr4_turn(j,i)+ &
11547                       wcorr5*gradcorr5(j,i)+ &
11548                       wcorr6*gradcorr6(j,i)+ &
11549                       wturn6*gcorr6_turn(j,i)+ &
11550                       wsccor*gsccorc(j,i) &
11551                      +wscloc*gscloc(j,i) &
11552                      +gradafm(j,i) &
11553                      +wliptran*gliptranc(j,i) &
11554                      +welec*gshieldc(j,i) &
11555                      +welec*gshieldc_loc(j,) &
11556                      +wcorr*gshieldc_ec(j,i) &
11557                      +wcorr*gshieldc_loc_ec(j,i) &
11558                      +wturn3*gshieldc_t3(j,i) &
11559                      +wturn3*gshieldc_loc_t3(j,i) &
11560                      +wturn4*gshieldc_t4(j,i) &
11561                      +wturn4*gshieldc_loc_t4(j,i) &
11562                      +wel_loc*gshieldc_ll(j,i) &
11563                      +wel_loc*gshieldc_loc_ll(j,i) &
11564                      +wtube*gg_tube(j,i) &
11565                      +wbond_nucl*gradb_nucl(j,i) &
11566                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11567                      +wvdwpsb*gvdwpsb1(j,i))&
11568                      +wsbloc*gsbloc(j,i)
11569
11570
11571
11572
11573 #endif
11574           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11575                         wbond*gradbx(j,i)+ &
11576                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11577                         wsccor*gsccorx(j,i) &
11578                        +wscloc*gsclocx(j,i) &
11579                        +wliptran*gliptranx(j,i) &
11580                        +welec*gshieldx(j,i)     &
11581                        +wcorr*gshieldx_ec(j,i)  &
11582                        +wturn3*gshieldx_t3(j,i) &
11583                        +wturn4*gshieldx_t4(j,i) &
11584                        +wel_loc*gshieldx_ll(j,i)&
11585                        +wtube*gg_tube_sc(j,i)   &
11586                        +wbond_nucl*gradbx_nucl(j,i) &
11587                        +wvdwsb*gvdwsbx(j,i) &
11588                        +welsb*gelsbx(j,i) &
11589                        +wcorr_nucl*gradxorr_nucl(j,i)&
11590                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11591                        +wsbloc*gsblocx(j,i) &
11592                        +wcatprot* gradpepcatx(j,i)&
11593                        +wscbase*gvdwx_scbase(j,i) &
11594                        +wpepbase*gvdwx_pepbase(j,i)&
11595                        +wscpho*gvdwx_scpho(j,i)
11596 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11597
11598         enddo
11599       enddo
11600 !#define DEBUG
11601 #ifdef DEBUG
11602       write (iout,*) "gloc before adding corr"
11603       do i=1,4*nres
11604         write (iout,*) i,gloc(i,icg)
11605       enddo
11606 #endif
11607       do i=1,nres-3
11608         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11609          +wcorr5*g_corr5_loc(i) &
11610          +wcorr6*g_corr6_loc(i) &
11611          +wturn4*gel_loc_turn4(i) &
11612          +wturn3*gel_loc_turn3(i) &
11613          +wturn6*gel_loc_turn6(i) &
11614          +wel_loc*gel_loc_loc(i)
11615       enddo
11616 #ifdef DEBUG
11617       write (iout,*) "gloc after adding corr"
11618       do i=1,4*nres
11619         write (iout,*) i,gloc(i,icg)
11620       enddo
11621 #endif
11622 !#undef DEBUG
11623 #ifdef MPI
11624       if (nfgtasks.gt.1) then
11625         do j=1,3
11626           do i=0,nres
11627             gradbufc(j,i)=gradc(j,i,icg)
11628             gradbufx(j,i)=gradx(j,i,icg)
11629           enddo
11630         enddo
11631         do i=1,4*nres
11632           glocbuf(i)=gloc(i,icg)
11633         enddo
11634 !#define DEBUG
11635 #ifdef DEBUG
11636       write (iout,*) "gloc_sc before reduce"
11637       do i=1,nres
11638        do j=1,1
11639         write (iout,*) i,j,gloc_sc(j,i,icg)
11640        enddo
11641       enddo
11642 #endif
11643 !#undef DEBUG
11644         do i=1,nres
11645          do j=1,3
11646           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11647          enddo
11648         enddo
11649         time00=MPI_Wtime()
11650         call MPI_Barrier(FG_COMM,IERR)
11651         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11652         time00=MPI_Wtime()
11653         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11654           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11655         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11656           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11657         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11658           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11659         time_reduce=time_reduce+MPI_Wtime()-time00
11660         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11661           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11662         time_reduce=time_reduce+MPI_Wtime()-time00
11663 !#define DEBUG
11664 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11665 #ifdef DEBUG
11666       write (iout,*) "gloc_sc after reduce"
11667       do i=1,nres
11668        do j=1,1
11669         write (iout,*) i,j,gloc_sc(j,i,icg)
11670        enddo
11671       enddo
11672 #endif
11673 !#undef DEBUG
11674 #ifdef DEBUG
11675       write (iout,*) "gloc after reduce"
11676       do i=1,4*nres
11677         write (iout,*) i,gloc(i,icg)
11678       enddo
11679 #endif
11680       endif
11681 #endif
11682       if (gnorm_check) then
11683 !
11684 ! Compute the maximum elements of the gradient
11685 !
11686       gvdwc_max=0.0d0
11687       gvdwc_scp_max=0.0d0
11688       gelc_max=0.0d0
11689       gvdwpp_max=0.0d0
11690       gradb_max=0.0d0
11691       ghpbc_max=0.0d0
11692       gradcorr_max=0.0d0
11693       gel_loc_max=0.0d0
11694       gcorr3_turn_max=0.0d0
11695       gcorr4_turn_max=0.0d0
11696       gradcorr5_max=0.0d0
11697       gradcorr6_max=0.0d0
11698       gcorr6_turn_max=0.0d0
11699       gsccorc_max=0.0d0
11700       gscloc_max=0.0d0
11701       gvdwx_max=0.0d0
11702       gradx_scp_max=0.0d0
11703       ghpbx_max=0.0d0
11704       gradxorr_max=0.0d0
11705       gsccorx_max=0.0d0
11706       gsclocx_max=0.0d0
11707       do i=1,nct
11708         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11709         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11710         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11711         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11712          gvdwc_scp_max=gvdwc_scp_norm
11713         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11714         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11715         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11716         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11717         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11718         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11719         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11720         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11721         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11722         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11723         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11724         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11725         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11726           gcorr3_turn(1,i)))
11727         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11728           gcorr3_turn_max=gcorr3_turn_norm
11729         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11730           gcorr4_turn(1,i)))
11731         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11732           gcorr4_turn_max=gcorr4_turn_norm
11733         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11734         if (gradcorr5_norm.gt.gradcorr5_max) &
11735           gradcorr5_max=gradcorr5_norm
11736         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11737         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11738         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11739           gcorr6_turn(1,i)))
11740         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11741           gcorr6_turn_max=gcorr6_turn_norm
11742         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11743         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11744         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11745         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11746         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11747         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11748         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11749         if (gradx_scp_norm.gt.gradx_scp_max) &
11750           gradx_scp_max=gradx_scp_norm
11751         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11752         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11753         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11754         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11755         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11756         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11757         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11758         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11759       enddo
11760       if (gradout) then
11761 #ifdef AIX
11762         open(istat,file=statname,position="append")
11763 #else
11764         open(istat,file=statname,access="append")
11765 #endif
11766         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11767            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11768            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11769            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11770            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11771            gsccorx_max,gsclocx_max
11772         close(istat)
11773         if (gvdwc_max.gt.1.0d4) then
11774           write (iout,*) "gvdwc gvdwx gradb gradbx"
11775           do i=nnt,nct
11776             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11777               gradb(j,i),gradbx(j,i),j=1,3)
11778           enddo
11779           call pdbout(0.0d0,'cipiszcze',iout)
11780           call flush(iout)
11781         endif
11782       endif
11783       endif
11784 !#define DEBUG
11785 #ifdef DEBUG
11786       write (iout,*) "gradc gradx gloc"
11787       do i=1,nres
11788         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11789          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11790       enddo
11791 #endif
11792 !#undef DEBUG
11793 #ifdef TIMING
11794       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11795 #endif
11796       return
11797       end subroutine sum_gradient
11798 !-----------------------------------------------------------------------------
11799       subroutine sc_grad
11800 !      implicit real*8 (a-h,o-z)
11801       use calc_data
11802 !      include 'DIMENSIONS'
11803 !      include 'COMMON.CHAIN'
11804 !      include 'COMMON.DERIV'
11805 !      include 'COMMON.CALC'
11806 !      include 'COMMON.IOUNITS'
11807       real(kind=8), dimension(3) :: dcosom1,dcosom2
11808 !      print *,"wchodze"
11809       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11810           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11811       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11812           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11813
11814       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11815            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11816            +dCAVdOM12+ dGCLdOM12
11817 ! diagnostics only
11818 !      eom1=0.0d0
11819 !      eom2=0.0d0
11820 !      eom12=evdwij*eps1_om12
11821 ! end diagnostics
11822 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11823 !       " sigder",sigder
11824 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11825 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11826 !C      print *,sss_ele_cut,'in sc_grad'
11827       do k=1,3
11828         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11829         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11830       enddo
11831       do k=1,3
11832         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11833 !C      print *,'gg',k,gg(k)
11834        enddo
11835 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11836 !      write (iout,*) "gg",(gg(k),k=1,3)
11837       do k=1,3
11838         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11839                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11840                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11841                   *sss_ele_cut
11842
11843         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11844                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11845                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11846                   *sss_ele_cut
11847
11848 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11849 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11850 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11851 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11852       enddo
11853 !
11854 ! Calculate the components of the gradient in DC and X
11855 !
11856 !grad      do k=i,j-1
11857 !grad        do l=1,3
11858 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11859 !grad        enddo
11860 !grad      enddo
11861       do l=1,3
11862         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11863         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11864       enddo
11865       return
11866       end subroutine sc_grad
11867 #ifdef CRYST_THETA
11868 !-----------------------------------------------------------------------------
11869       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11870
11871       use comm_calcthet
11872 !      implicit real*8 (a-h,o-z)
11873 !      include 'DIMENSIONS'
11874 !      include 'COMMON.LOCAL'
11875 !      include 'COMMON.IOUNITS'
11876 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11877 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11878 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11879       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11880       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11881 !el      integer :: it
11882 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11883 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11884 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11885 !el local variables
11886
11887       delthec=thetai-thet_pred_mean
11888       delthe0=thetai-theta0i
11889 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11890       t3 = thetai-thet_pred_mean
11891       t6 = t3**2
11892       t9 = term1
11893       t12 = t3*sigcsq
11894       t14 = t12+t6*sigsqtc
11895       t16 = 1.0d0
11896       t21 = thetai-theta0i
11897       t23 = t21**2
11898       t26 = term2
11899       t27 = t21*t26
11900       t32 = termexp
11901       t40 = t32**2
11902       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11903        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11904        *(-t12*t9-ak*sig0inv*t27)
11905       return
11906       end subroutine mixder
11907 #endif
11908 !-----------------------------------------------------------------------------
11909 ! cartder.F
11910 !-----------------------------------------------------------------------------
11911       subroutine cartder
11912 !-----------------------------------------------------------------------------
11913 ! This subroutine calculates the derivatives of the consecutive virtual
11914 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11915 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11916 ! in the angles alpha and omega, describing the location of a side chain
11917 ! in its local coordinate system.
11918 !
11919 ! The derivatives are stored in the following arrays:
11920 !
11921 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11922 ! The structure is as follows:
11923 !
11924 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11925 ! 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)
11926 !         . . . . . . . . . . . .  . . . . . .
11927 ! 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)
11928 !                          .
11929 !                          .
11930 !                          .
11931 ! 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)
11932 !
11933 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11934 ! The structure is same as above.
11935 !
11936 ! DCDS - the derivatives of the side chain vectors in the local spherical
11937 ! andgles alph and omega:
11938 !
11939 ! 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)
11940 ! 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)
11941 !                          .
11942 !                          .
11943 !                          .
11944 ! 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)
11945 !
11946 ! Version of March '95, based on an early version of November '91.
11947 !
11948 !**********************************************************************
11949 !      implicit real*8 (a-h,o-z)
11950 !      include 'DIMENSIONS'
11951 !      include 'COMMON.VAR'
11952 !      include 'COMMON.CHAIN'
11953 !      include 'COMMON.DERIV'
11954 !      include 'COMMON.GEO'
11955 !      include 'COMMON.LOCAL'
11956 !      include 'COMMON.INTERACT'
11957       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11958       real(kind=8),dimension(3,3) :: dp,temp
11959 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11960       real(kind=8),dimension(3) :: xx,xx1
11961 !el local variables
11962       integer :: i,k,l,j,m,ind,ind1,jjj
11963       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11964                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11965                  sint2,xp,yp,xxp,yyp,zzp,dj
11966
11967 !      common /przechowalnia/ fromto
11968       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11969 ! get the position of the jth ijth fragment of the chain coordinate system
11970 ! in the fromto array.
11971 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11972 !
11973 !      maxdim=(nres-1)*(nres-2)/2
11974 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11975 ! calculate the derivatives of transformation matrix elements in theta
11976 !
11977
11978 !el      call flush(iout) !el
11979       do i=1,nres-2
11980         rdt(1,1,i)=-rt(1,2,i)
11981         rdt(1,2,i)= rt(1,1,i)
11982         rdt(1,3,i)= 0.0d0
11983         rdt(2,1,i)=-rt(2,2,i)
11984         rdt(2,2,i)= rt(2,1,i)
11985         rdt(2,3,i)= 0.0d0
11986         rdt(3,1,i)=-rt(3,2,i)
11987         rdt(3,2,i)= rt(3,1,i)
11988         rdt(3,3,i)= 0.0d0
11989       enddo
11990 !
11991 ! derivatives in phi
11992 !
11993       do i=2,nres-2
11994         drt(1,1,i)= 0.0d0
11995         drt(1,2,i)= 0.0d0
11996         drt(1,3,i)= 0.0d0
11997         drt(2,1,i)= rt(3,1,i)
11998         drt(2,2,i)= rt(3,2,i)
11999         drt(2,3,i)= rt(3,3,i)
12000         drt(3,1,i)=-rt(2,1,i)
12001         drt(3,2,i)=-rt(2,2,i)
12002         drt(3,3,i)=-rt(2,3,i)
12003       enddo
12004 !
12005 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12006 !
12007       do i=2,nres-2
12008         ind=indmat(i,i+1)
12009         do k=1,3
12010           do l=1,3
12011             temp(k,l)=rt(k,l,i)
12012           enddo
12013         enddo
12014         do k=1,3
12015           do l=1,3
12016             fromto(k,l,ind)=temp(k,l)
12017           enddo
12018         enddo
12019         do j=i+1,nres-2
12020           ind=indmat(i,j+1)
12021           do k=1,3
12022             do l=1,3
12023               dpkl=0.0d0
12024               do m=1,3
12025                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12026               enddo
12027               dp(k,l)=dpkl
12028               fromto(k,l,ind)=dpkl
12029             enddo
12030           enddo
12031           do k=1,3
12032             do l=1,3
12033               temp(k,l)=dp(k,l)
12034             enddo
12035           enddo
12036         enddo
12037       enddo
12038 !
12039 ! Calculate derivatives.
12040 !
12041       ind1=0
12042       do i=1,nres-2
12043       ind1=ind1+1
12044 !
12045 ! Derivatives of DC(i+1) in theta(i+2)
12046 !
12047         do j=1,3
12048           do k=1,2
12049             dpjk=0.0D0
12050             do l=1,3
12051               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12052             enddo
12053             dp(j,k)=dpjk
12054             prordt(j,k,i)=dp(j,k)
12055           enddo
12056           dp(j,3)=0.0D0
12057           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12058         enddo
12059 !
12060 ! Derivatives of SC(i+1) in theta(i+2)
12061 !
12062         xx1(1)=-0.5D0*xloc(2,i+1)
12063         xx1(2)= 0.5D0*xloc(1,i+1)
12064         do j=1,3
12065           xj=0.0D0
12066           do k=1,2
12067             xj=xj+r(j,k,i)*xx1(k)
12068           enddo
12069           xx(j)=xj
12070         enddo
12071         do j=1,3
12072           rj=0.0D0
12073           do k=1,3
12074             rj=rj+prod(j,k,i)*xx(k)
12075           enddo
12076           dxdv(j,ind1)=rj
12077         enddo
12078 !
12079 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12080 ! than the other off-diagonal derivatives.
12081 !
12082         do j=1,3
12083           dxoiij=0.0D0
12084           do k=1,3
12085             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12086           enddo
12087           dxdv(j,ind1+1)=dxoiij
12088         enddo
12089 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12090 !
12091 ! Derivatives of DC(i+1) in phi(i+2)
12092 !
12093         do j=1,3
12094           do k=1,3
12095             dpjk=0.0
12096             do l=2,3
12097               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12098             enddo
12099             dp(j,k)=dpjk
12100             prodrt(j,k,i)=dp(j,k)
12101           enddo
12102           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12103         enddo
12104 !
12105 ! Derivatives of SC(i+1) in phi(i+2)
12106 !
12107         xx(1)= 0.0D0
12108         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12109         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12110         do j=1,3
12111           rj=0.0D0
12112           do k=2,3
12113             rj=rj+prod(j,k,i)*xx(k)
12114           enddo
12115           dxdv(j+3,ind1)=-rj
12116         enddo
12117 !
12118 ! Derivatives of SC(i+1) in phi(i+3).
12119 !
12120         do j=1,3
12121           dxoiij=0.0D0
12122           do k=1,3
12123             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12124           enddo
12125           dxdv(j+3,ind1+1)=dxoiij
12126         enddo
12127 !
12128 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12129 ! theta(nres) and phi(i+3) thru phi(nres).
12130 !
12131         do j=i+1,nres-2
12132         ind1=ind1+1
12133         ind=indmat(i+1,j+1)
12134 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12135           do k=1,3
12136             do l=1,3
12137               tempkl=0.0D0
12138               do m=1,2
12139                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12140               enddo
12141               temp(k,l)=tempkl
12142             enddo
12143           enddo
12144 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12145 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12146 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12147 ! Derivatives of virtual-bond vectors in theta
12148           do k=1,3
12149             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12150           enddo
12151 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12152 ! Derivatives of SC vectors in theta
12153           do k=1,3
12154             dxoijk=0.0D0
12155             do l=1,3
12156               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12157             enddo
12158             dxdv(k,ind1+1)=dxoijk
12159           enddo
12160 !
12161 !--- Calculate the derivatives in phi
12162 !
12163           do k=1,3
12164             do l=1,3
12165               tempkl=0.0D0
12166               do m=1,3
12167                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12168               enddo
12169               temp(k,l)=tempkl
12170             enddo
12171           enddo
12172           do k=1,3
12173             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12174         enddo
12175           do k=1,3
12176             dxoijk=0.0D0
12177             do l=1,3
12178               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12179             enddo
12180             dxdv(k+3,ind1+1)=dxoijk
12181           enddo
12182         enddo
12183       enddo
12184 !
12185 ! Derivatives in alpha and omega:
12186 !
12187       do i=2,nres-1
12188 !       dsci=dsc(itype(i,1))
12189         dsci=vbld(i+nres)
12190 #ifdef OSF
12191         alphi=alph(i)
12192         omegi=omeg(i)
12193         if(alphi.ne.alphi) alphi=100.0
12194         if(omegi.ne.omegi) omegi=-100.0
12195 #else
12196       alphi=alph(i)
12197       omegi=omeg(i)
12198 #endif
12199 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12200       cosalphi=dcos(alphi)
12201       sinalphi=dsin(alphi)
12202       cosomegi=dcos(omegi)
12203       sinomegi=dsin(omegi)
12204       temp(1,1)=-dsci*sinalphi
12205       temp(2,1)= dsci*cosalphi*cosomegi
12206       temp(3,1)=-dsci*cosalphi*sinomegi
12207       temp(1,2)=0.0D0
12208       temp(2,2)=-dsci*sinalphi*sinomegi
12209       temp(3,2)=-dsci*sinalphi*cosomegi
12210       theta2=pi-0.5D0*theta(i+1)
12211       cost2=dcos(theta2)
12212       sint2=dsin(theta2)
12213       jjj=0
12214 !d      print *,((temp(l,k),l=1,3),k=1,2)
12215         do j=1,2
12216         xp=temp(1,j)
12217         yp=temp(2,j)
12218         xxp= xp*cost2+yp*sint2
12219         yyp=-xp*sint2+yp*cost2
12220         zzp=temp(3,j)
12221         xx(1)=xxp
12222         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12223         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12224         do k=1,3
12225           dj=0.0D0
12226           do l=1,3
12227             dj=dj+prod(k,l,i-1)*xx(l)
12228             enddo
12229           dxds(jjj+k,i)=dj
12230           enddo
12231         jjj=jjj+3
12232       enddo
12233       enddo
12234       return
12235       end subroutine cartder
12236 !-----------------------------------------------------------------------------
12237 ! checkder_p.F
12238 !-----------------------------------------------------------------------------
12239       subroutine check_cartgrad
12240 ! Check the gradient of Cartesian coordinates in internal coordinates.
12241 !      implicit real*8 (a-h,o-z)
12242 !      include 'DIMENSIONS'
12243 !      include 'COMMON.IOUNITS'
12244 !      include 'COMMON.VAR'
12245 !      include 'COMMON.CHAIN'
12246 !      include 'COMMON.GEO'
12247 !      include 'COMMON.LOCAL'
12248 !      include 'COMMON.DERIV'
12249       real(kind=8),dimension(6,nres) :: temp
12250       real(kind=8),dimension(3) :: xx,gg
12251       integer :: i,k,j,ii
12252       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12253 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12254 !
12255 ! Check the gradient of the virtual-bond and SC vectors in the internal
12256 ! coordinates.
12257 !
12258       aincr=1.0d-6
12259       aincr2=5.0d-7
12260       call cartder
12261       write (iout,'(a)') '**************** dx/dalpha'
12262       write (iout,'(a)')
12263       do i=2,nres-1
12264       alphi=alph(i)
12265       alph(i)=alph(i)+aincr
12266       do k=1,3
12267         temp(k,i)=dc(k,nres+i)
12268         enddo
12269       call chainbuild
12270       do k=1,3
12271         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12272         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12273         enddo
12274         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12275         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12276         write (iout,'(a)')
12277       alph(i)=alphi
12278       call chainbuild
12279       enddo
12280       write (iout,'(a)')
12281       write (iout,'(a)') '**************** dx/domega'
12282       write (iout,'(a)')
12283       do i=2,nres-1
12284       omegi=omeg(i)
12285       omeg(i)=omeg(i)+aincr
12286       do k=1,3
12287         temp(k,i)=dc(k,nres+i)
12288         enddo
12289       call chainbuild
12290       do k=1,3
12291           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12292           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12293                 (aincr*dabs(dxds(k+3,i))+aincr))
12294         enddo
12295         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12296             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12297         write (iout,'(a)')
12298       omeg(i)=omegi
12299       call chainbuild
12300       enddo
12301       write (iout,'(a)')
12302       write (iout,'(a)') '**************** dx/dtheta'
12303       write (iout,'(a)')
12304       do i=3,nres
12305       theti=theta(i)
12306         theta(i)=theta(i)+aincr
12307         do j=i-1,nres-1
12308           do k=1,3
12309             temp(k,j)=dc(k,nres+j)
12310           enddo
12311         enddo
12312         call chainbuild
12313         do j=i-1,nres-1
12314         ii = indmat(i-2,j)
12315 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12316         do k=1,3
12317           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12318           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12319                   (aincr*dabs(dxdv(k,ii))+aincr))
12320           enddo
12321           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12322               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12323           write(iout,'(a)')
12324         enddo
12325         write (iout,'(a)')
12326         theta(i)=theti
12327         call chainbuild
12328       enddo
12329       write (iout,'(a)') '***************** dx/dphi'
12330       write (iout,'(a)')
12331       do i=4,nres
12332         phi(i)=phi(i)+aincr
12333         do j=i-1,nres-1
12334           do k=1,3
12335             temp(k,j)=dc(k,nres+j)
12336           enddo
12337         enddo
12338         call chainbuild
12339         do j=i-1,nres-1
12340         ii = indmat(i-2,j)
12341 !         print *,'ii=',ii
12342         do k=1,3
12343           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12344             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12345                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12346           enddo
12347           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12348               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12349           write(iout,'(a)')
12350         enddo
12351         phi(i)=phi(i)-aincr
12352         call chainbuild
12353       enddo
12354       write (iout,'(a)') '****************** ddc/dtheta'
12355       do i=1,nres-2
12356         thet=theta(i+2)
12357         theta(i+2)=thet+aincr
12358         do j=i,nres
12359           do k=1,3
12360             temp(k,j)=dc(k,j)
12361           enddo
12362         enddo
12363         call chainbuild
12364         do j=i+1,nres-1
12365         ii = indmat(i,j)
12366 !         print *,'ii=',ii
12367         do k=1,3
12368           gg(k)=(dc(k,j)-temp(k,j))/aincr
12369           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12370                  (aincr*dabs(dcdv(k,ii))+aincr))
12371           enddo
12372           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12373                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12374         write (iout,'(a)')
12375         enddo
12376         do j=1,nres
12377           do k=1,3
12378             dc(k,j)=temp(k,j)
12379           enddo
12380         enddo
12381         theta(i+2)=thet
12382       enddo
12383       write (iout,'(a)') '******************* ddc/dphi'
12384       do i=1,nres-3
12385         phii=phi(i+3)
12386         phi(i+3)=phii+aincr
12387         do j=1,nres
12388           do k=1,3
12389             temp(k,j)=dc(k,j)
12390           enddo
12391         enddo
12392         call chainbuild
12393         do j=i+2,nres-1
12394         ii = indmat(i+1,j)
12395 !         print *,'ii=',ii
12396         do k=1,3
12397           gg(k)=(dc(k,j)-temp(k,j))/aincr
12398             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12399                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12400           enddo
12401           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12402                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12403         write (iout,'(a)')
12404         enddo
12405         do j=1,nres
12406           do k=1,3
12407             dc(k,j)=temp(k,j)
12408           enddo
12409         enddo
12410         phi(i+3)=phii
12411       enddo
12412       return
12413       end subroutine check_cartgrad
12414 !-----------------------------------------------------------------------------
12415       subroutine check_ecart
12416 ! Check the gradient of the energy in Cartesian coordinates.
12417 !     implicit real*8 (a-h,o-z)
12418 !     include 'DIMENSIONS'
12419 !     include 'COMMON.CHAIN'
12420 !     include 'COMMON.DERIV'
12421 !     include 'COMMON.IOUNITS'
12422 !     include 'COMMON.VAR'
12423 !     include 'COMMON.CONTACTS'
12424       use comm_srutu
12425 !el      integer :: icall
12426 !el      common /srutu/ icall
12427       real(kind=8),dimension(6) :: ggg
12428       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12429       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12430       real(kind=8),dimension(6,nres) :: grad_s
12431       real(kind=8),dimension(0:n_ene) :: energia,energia1
12432       integer :: uiparm(1)
12433       real(kind=8) :: urparm(1)
12434 !EL      external fdum
12435       integer :: nf,i,j,k
12436       real(kind=8) :: aincr,etot,etot1
12437       icg=1
12438       nf=0
12439       nfl=0
12440       call zerograd
12441       aincr=1.0D-5
12442       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12443       nf=0
12444       icall=0
12445       call geom_to_var(nvar,x)
12446       call etotal(energia)
12447       etot=energia(0)
12448 !el      call enerprint(energia)
12449       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12450       icall =1
12451       do i=1,nres
12452         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12453       enddo
12454       do i=1,nres
12455       do j=1,3
12456         grad_s(j,i)=gradc(j,i,icg)
12457         grad_s(j+3,i)=gradx(j,i,icg)
12458         enddo
12459       enddo
12460       call flush(iout)
12461       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12462       do i=1,nres
12463         do j=1,3
12464         xx(j)=c(j,i+nres)
12465         ddc(j)=dc(j,i)
12466         ddx(j)=dc(j,i+nres)
12467         enddo
12468       do j=1,3
12469         dc(j,i)=dc(j,i)+aincr
12470         do k=i+1,nres
12471           c(j,k)=c(j,k)+aincr
12472           c(j,k+nres)=c(j,k+nres)+aincr
12473           enddo
12474           call zerograd
12475           call etotal(energia1)
12476           etot1=energia1(0)
12477         ggg(j)=(etot1-etot)/aincr
12478         dc(j,i)=ddc(j)
12479         do k=i+1,nres
12480           c(j,k)=c(j,k)-aincr
12481           c(j,k+nres)=c(j,k+nres)-aincr
12482           enddo
12483         enddo
12484       do j=1,3
12485         c(j,i+nres)=c(j,i+nres)+aincr
12486         dc(j,i+nres)=dc(j,i+nres)+aincr
12487           call zerograd
12488           call etotal(energia1)
12489           etot1=energia1(0)
12490         ggg(j+3)=(etot1-etot)/aincr
12491         c(j,i+nres)=xx(j)
12492         dc(j,i+nres)=ddx(j)
12493         enddo
12494       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12495          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12496       enddo
12497       return
12498       end subroutine check_ecart
12499 #ifdef CARGRAD
12500 !-----------------------------------------------------------------------------
12501       subroutine check_ecartint
12502 ! Check the gradient of the energy in Cartesian coordinates.
12503       use io_base, only: intout
12504 !      implicit real*8 (a-h,o-z)
12505 !      include 'DIMENSIONS'
12506 !      include 'COMMON.CONTROL'
12507 !      include 'COMMON.CHAIN'
12508 !      include 'COMMON.DERIV'
12509 !      include 'COMMON.IOUNITS'
12510 !      include 'COMMON.VAR'
12511 !      include 'COMMON.CONTACTS'
12512 !      include 'COMMON.MD'
12513 !      include 'COMMON.LOCAL'
12514 !      include 'COMMON.SPLITELE'
12515       use comm_srutu
12516 !el      integer :: icall
12517 !el      common /srutu/ icall
12518       real(kind=8),dimension(6) :: ggg,ggg1
12519       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12520       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12521       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12522       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12523       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12524       real(kind=8),dimension(0:n_ene) :: energia,energia1
12525       integer :: uiparm(1)
12526       real(kind=8) :: urparm(1)
12527 !EL      external fdum
12528       integer :: i,j,k,nf
12529       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12530                    etot21,etot22
12531       r_cut=2.0d0
12532       rlambd=0.3d0
12533       icg=1
12534       nf=0
12535       nfl=0
12536       call intout
12537 !      call intcartderiv
12538 !      call checkintcartgrad
12539       call zerograd
12540       aincr=1.0D-4
12541       write(iout,*) 'Calling CHECK_ECARTINT.'
12542       nf=0
12543       icall=0
12544       call geom_to_var(nvar,x)
12545       write (iout,*) "split_ene ",split_ene
12546       call flush(iout)
12547       if (.not.split_ene) then
12548         call zerograd
12549         call etotal(energia)
12550         etot=energia(0)
12551         call cartgrad
12552         icall =1
12553         do i=1,nres
12554           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12555         enddo
12556         do j=1,3
12557           grad_s(j,0)=gcart(j,0)
12558         enddo
12559         do i=1,nres
12560           do j=1,3
12561             grad_s(j,i)=gcart(j,i)
12562             grad_s(j+3,i)=gxcart(j,i)
12563           enddo
12564         enddo
12565       else
12566 !- split gradient check
12567         call zerograd
12568         call etotal_long(energia)
12569 !el        call enerprint(energia)
12570         call cartgrad
12571         icall =1
12572         do i=1,nres
12573           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12574           (gxcart(j,i),j=1,3)
12575         enddo
12576         do j=1,3
12577           grad_s(j,0)=gcart(j,0)
12578         enddo
12579         do i=1,nres
12580           do j=1,3
12581             grad_s(j,i)=gcart(j,i)
12582             grad_s(j+3,i)=gxcart(j,i)
12583           enddo
12584         enddo
12585         call zerograd
12586         call etotal_short(energia)
12587         call enerprint(energia)
12588         call cartgrad
12589         icall =1
12590         do i=1,nres
12591           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12592           (gxcart(j,i),j=1,3)
12593         enddo
12594         do j=1,3
12595           grad_s1(j,0)=gcart(j,0)
12596         enddo
12597         do i=1,nres
12598           do j=1,3
12599             grad_s1(j,i)=gcart(j,i)
12600             grad_s1(j+3,i)=gxcart(j,i)
12601           enddo
12602         enddo
12603       endif
12604       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12605 !      do i=1,nres
12606       do i=nnt,nct
12607         do j=1,3
12608           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12609           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12610         ddc(j)=c(j,i)
12611         ddx(j)=c(j,i+nres)
12612           dcnorm_safe1(j)=dc_norm(j,i-1)
12613           dcnorm_safe2(j)=dc_norm(j,i)
12614           dxnorm_safe(j)=dc_norm(j,i+nres)
12615         enddo
12616       do j=1,3
12617         c(j,i)=ddc(j)+aincr
12618           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12619           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12620           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12621           dc(j,i)=c(j,i+1)-c(j,i)
12622           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12623           call int_from_cart1(.false.)
12624           if (.not.split_ene) then
12625            call zerograd
12626             call etotal(energia1)
12627             etot1=energia1(0)
12628             write (iout,*) "ij",i,j," etot1",etot1
12629           else
12630 !- split gradient
12631             call etotal_long(energia1)
12632             etot11=energia1(0)
12633             call etotal_short(energia1)
12634             etot12=energia1(0)
12635           endif
12636 !- end split gradient
12637 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12638         c(j,i)=ddc(j)-aincr
12639           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12640           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12641           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12642           dc(j,i)=c(j,i+1)-c(j,i)
12643           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12644           call int_from_cart1(.false.)
12645           if (.not.split_ene) then
12646             call zerograd
12647             call etotal(energia1)
12648             etot2=energia1(0)
12649             write (iout,*) "ij",i,j," etot2",etot2
12650           ggg(j)=(etot1-etot2)/(2*aincr)
12651           else
12652 !- split gradient
12653             call etotal_long(energia1)
12654             etot21=energia1(0)
12655           ggg(j)=(etot11-etot21)/(2*aincr)
12656             call etotal_short(energia1)
12657             etot22=energia1(0)
12658           ggg1(j)=(etot12-etot22)/(2*aincr)
12659 !- end split gradient
12660 !            write (iout,*) "etot21",etot21," etot22",etot22
12661           endif
12662 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12663         c(j,i)=ddc(j)
12664           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12665           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12666           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12667           dc(j,i)=c(j,i+1)-c(j,i)
12668           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12669           dc_norm(j,i-1)=dcnorm_safe1(j)
12670           dc_norm(j,i)=dcnorm_safe2(j)
12671           dc_norm(j,i+nres)=dxnorm_safe(j)
12672         enddo
12673       do j=1,3
12674         c(j,i+nres)=ddx(j)+aincr
12675           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12676           call int_from_cart1(.false.)
12677           if (.not.split_ene) then
12678             call zerograd
12679             call etotal(energia1)
12680             etot1=energia1(0)
12681           else
12682 !- split gradient
12683             call etotal_long(energia1)
12684             etot11=energia1(0)
12685             call etotal_short(energia1)
12686             etot12=energia1(0)
12687           endif
12688 !- end split gradient
12689         c(j,i+nres)=ddx(j)-aincr
12690           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12691           call int_from_cart1(.false.)
12692           if (.not.split_ene) then
12693            call zerograd
12694            call etotal(energia1)
12695             etot2=energia1(0)
12696           ggg(j+3)=(etot1-etot2)/(2*aincr)
12697           else
12698 !- split gradient
12699             call etotal_long(energia1)
12700             etot21=energia1(0)
12701           ggg(j+3)=(etot11-etot21)/(2*aincr)
12702             call etotal_short(energia1)
12703             etot22=energia1(0)
12704           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12705 !- end split gradient
12706           endif
12707 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12708         c(j,i+nres)=ddx(j)
12709           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12710           dc_norm(j,i+nres)=dxnorm_safe(j)
12711           call int_from_cart1(.false.)
12712         enddo
12713       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12714          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12715         if (split_ene) then
12716           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12717          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12718          k=1,6)
12719          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12720          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12721          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12722         endif
12723       enddo
12724       return
12725       end subroutine check_ecartint
12726 #else
12727 !-----------------------------------------------------------------------------
12728       subroutine check_ecartint
12729 ! Check the gradient of the energy in Cartesian coordinates.
12730       use io_base, only: intout
12731 !      implicit real*8 (a-h,o-z)
12732 !      include 'DIMENSIONS'
12733 !      include 'COMMON.CONTROL'
12734 !      include 'COMMON.CHAIN'
12735 !      include 'COMMON.DERIV'
12736 !      include 'COMMON.IOUNITS'
12737 !      include 'COMMON.VAR'
12738 !      include 'COMMON.CONTACTS'
12739 !      include 'COMMON.MD'
12740 !      include 'COMMON.LOCAL'
12741 !      include 'COMMON.SPLITELE'
12742       use comm_srutu
12743 !el      integer :: icall
12744 !el      common /srutu/ icall
12745       real(kind=8),dimension(6) :: ggg,ggg1
12746       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12747       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12748       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12749       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12750       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12751       real(kind=8),dimension(0:n_ene) :: energia,energia1
12752       integer :: uiparm(1)
12753       real(kind=8) :: urparm(1)
12754 !EL      external fdum
12755       integer :: i,j,k,nf
12756       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12757                    etot21,etot22
12758       r_cut=2.0d0
12759       rlambd=0.3d0
12760       icg=1
12761       nf=0
12762       nfl=0
12763       call intout
12764 !      call intcartderiv
12765 !      call checkintcartgrad
12766       call zerograd
12767       aincr=1.0D-7
12768       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12769       nf=0
12770       icall=0
12771       call geom_to_var(nvar,x)
12772       if (.not.split_ene) then
12773         call etotal(energia)
12774         etot=energia(0)
12775 !el        call enerprint(energia)
12776         call cartgrad
12777         icall =1
12778         do i=1,nres
12779           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12780         enddo
12781         do j=1,3
12782           grad_s(j,0)=gcart(j,0)
12783         enddo
12784         do i=1,nres
12785           do j=1,3
12786             grad_s(j,i)=gcart(j,i)
12787 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12788
12789 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12790             grad_s(j+3,i)=gxcart(j,i)
12791           enddo
12792         enddo
12793       else
12794 !- split gradient check
12795         call zerograd
12796         call etotal_long(energia)
12797 !el        call enerprint(energia)
12798         call cartgrad
12799         icall =1
12800         do i=1,nres
12801           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12802           (gxcart(j,i),j=1,3)
12803         enddo
12804         do j=1,3
12805           grad_s(j,0)=gcart(j,0)
12806         enddo
12807         do i=1,nres
12808           do j=1,3
12809             grad_s(j,i)=gcart(j,i)
12810 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12811             grad_s(j+3,i)=gxcart(j,i)
12812           enddo
12813         enddo
12814         call zerograd
12815         call etotal_short(energia)
12816 !el        call enerprint(energia)
12817         call cartgrad
12818         icall =1
12819         do i=1,nres
12820           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12821           (gxcart(j,i),j=1,3)
12822         enddo
12823         do j=1,3
12824           grad_s1(j,0)=gcart(j,0)
12825         enddo
12826         do i=1,nres
12827           do j=1,3
12828             grad_s1(j,i)=gcart(j,i)
12829             grad_s1(j+3,i)=gxcart(j,i)
12830           enddo
12831         enddo
12832       endif
12833       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12834       do i=0,nres
12835         do j=1,3
12836         xx(j)=c(j,i+nres)
12837         ddc(j)=dc(j,i)
12838         ddx(j)=dc(j,i+nres)
12839           do k=1,3
12840             dcnorm_safe(k)=dc_norm(k,i)
12841             dxnorm_safe(k)=dc_norm(k,i+nres)
12842           enddo
12843         enddo
12844       do j=1,3
12845         dc(j,i)=ddc(j)+aincr
12846           call chainbuild_cart
12847 #ifdef MPI
12848 ! Broadcast the order to compute internal coordinates to the slaves.
12849 !          if (nfgtasks.gt.1)
12850 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12851 #endif
12852 !          call int_from_cart1(.false.)
12853           if (.not.split_ene) then
12854            call zerograd
12855             call etotal(energia1)
12856             etot1=energia1(0)
12857 !            call enerprint(energia1)
12858           else
12859 !- split gradient
12860             call etotal_long(energia1)
12861             etot11=energia1(0)
12862             call etotal_short(energia1)
12863             etot12=energia1(0)
12864 !            write (iout,*) "etot11",etot11," etot12",etot12
12865           endif
12866 !- end split gradient
12867 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12868         dc(j,i)=ddc(j)-aincr
12869           call chainbuild_cart
12870 !          call int_from_cart1(.false.)
12871           if (.not.split_ene) then
12872                   call zerograd
12873             call etotal(energia1)
12874             etot2=energia1(0)
12875           ggg(j)=(etot1-etot2)/(2*aincr)
12876           else
12877 !- split gradient
12878             call etotal_long(energia1)
12879             etot21=energia1(0)
12880           ggg(j)=(etot11-etot21)/(2*aincr)
12881             call etotal_short(energia1)
12882             etot22=energia1(0)
12883           ggg1(j)=(etot12-etot22)/(2*aincr)
12884 !- end split gradient
12885 !            write (iout,*) "etot21",etot21," etot22",etot22
12886           endif
12887 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12888         dc(j,i)=ddc(j)
12889           call chainbuild_cart
12890         enddo
12891       do j=1,3
12892         dc(j,i+nres)=ddx(j)+aincr
12893           call chainbuild_cart
12894 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12895 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12896 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12897 !          write (iout,*) "dxnormnorm",dsqrt(
12898 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12899 !          write (iout,*) "dxnormnormsafe",dsqrt(
12900 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12901 !          write (iout,*)
12902           if (.not.split_ene) then
12903             call zerograd
12904             call etotal(energia1)
12905             etot1=energia1(0)
12906           else
12907 !- split gradient
12908             call etotal_long(energia1)
12909             etot11=energia1(0)
12910             call etotal_short(energia1)
12911             etot12=energia1(0)
12912           endif
12913 !- end split gradient
12914 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12915         dc(j,i+nres)=ddx(j)-aincr
12916           call chainbuild_cart
12917 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12918 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12919 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12920 !          write (iout,*)
12921 !          write (iout,*) "dxnormnorm",dsqrt(
12922 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12923 !          write (iout,*) "dxnormnormsafe",dsqrt(
12924 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12925           if (.not.split_ene) then
12926             call zerograd
12927             call etotal(energia1)
12928             etot2=energia1(0)
12929           ggg(j+3)=(etot1-etot2)/(2*aincr)
12930           else
12931 !- split gradient
12932             call etotal_long(energia1)
12933             etot21=energia1(0)
12934           ggg(j+3)=(etot11-etot21)/(2*aincr)
12935             call etotal_short(energia1)
12936             etot22=energia1(0)
12937           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12938 !- end split gradient
12939           endif
12940 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12941         dc(j,i+nres)=ddx(j)
12942           call chainbuild_cart
12943         enddo
12944       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12945          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12946         if (split_ene) then
12947           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12948          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12949          k=1,6)
12950          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12951          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12952          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12953         endif
12954       enddo
12955       return
12956       end subroutine check_ecartint
12957 #endif
12958 !-----------------------------------------------------------------------------
12959       subroutine check_eint
12960 ! Check the gradient of energy in internal coordinates.
12961 !      implicit real*8 (a-h,o-z)
12962 !      include 'DIMENSIONS'
12963 !      include 'COMMON.CHAIN'
12964 !      include 'COMMON.DERIV'
12965 !      include 'COMMON.IOUNITS'
12966 !      include 'COMMON.VAR'
12967 !      include 'COMMON.GEO'
12968       use comm_srutu
12969 !el      integer :: icall
12970 !el      common /srutu/ icall
12971       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12972       integer :: uiparm(1)
12973       real(kind=8) :: urparm(1)
12974       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12975       character(len=6) :: key
12976 !EL      external fdum
12977       integer :: i,ii,nf
12978       real(kind=8) :: xi,aincr,etot,etot1,etot2
12979       call zerograd
12980       aincr=1.0D-7
12981       print '(a)','Calling CHECK_INT.'
12982       nf=0
12983       nfl=0
12984       icg=1
12985       call geom_to_var(nvar,x)
12986       call var_to_geom(nvar,x)
12987       call chainbuild
12988       icall=1
12989 !      print *,'ICG=',ICG
12990       call etotal(energia)
12991       etot = energia(0)
12992 !el      call enerprint(energia)
12993 !      print *,'ICG=',ICG
12994 #ifdef MPL
12995       if (MyID.ne.BossID) then
12996         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12997         nf=x(nvar+1)
12998         nfl=x(nvar+2)
12999         icg=x(nvar+3)
13000       endif
13001 #endif
13002       nf=1
13003       nfl=3
13004 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13005       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13006 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13007       icall=1
13008       do i=1,nvar
13009         xi=x(i)
13010         x(i)=xi-0.5D0*aincr
13011         call var_to_geom(nvar,x)
13012         call chainbuild
13013         call etotal(energia1)
13014         etot1=energia1(0)
13015         x(i)=xi+0.5D0*aincr
13016         call var_to_geom(nvar,x)
13017         call chainbuild
13018         call etotal(energia2)
13019         etot2=energia2(0)
13020         gg(i)=(etot2-etot1)/aincr
13021         write (iout,*) i,etot1,etot2
13022         x(i)=xi
13023       enddo
13024       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13025           '     RelDiff*100% '
13026       do i=1,nvar
13027         if (i.le.nphi) then
13028           ii=i
13029           key = ' phi'
13030         else if (i.le.nphi+ntheta) then
13031           ii=i-nphi
13032           key=' theta'
13033         else if (i.le.nphi+ntheta+nside) then
13034            ii=i-(nphi+ntheta)
13035            key=' alpha'
13036         else
13037            ii=i-(nphi+ntheta+nside)
13038            key=' omega'
13039         endif
13040         write (iout,'(i3,a,i3,3(1pd16.6))') &
13041        i,key,ii,gg(i),gana(i),&
13042        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13043       enddo
13044       return
13045       end subroutine check_eint
13046 !-----------------------------------------------------------------------------
13047 ! econstr_local.F
13048 !-----------------------------------------------------------------------------
13049       subroutine Econstr_back
13050 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13051 !      implicit real*8 (a-h,o-z)
13052 !      include 'DIMENSIONS'
13053 !      include 'COMMON.CONTROL'
13054 !      include 'COMMON.VAR'
13055 !      include 'COMMON.MD'
13056       use MD_data
13057 !#ifndef LANG0
13058 !      include 'COMMON.LANGEVIN'
13059 !#else
13060 !      include 'COMMON.LANGEVIN.lang0'
13061 !#endif
13062 !      include 'COMMON.CHAIN'
13063 !      include 'COMMON.DERIV'
13064 !      include 'COMMON.GEO'
13065 !      include 'COMMON.LOCAL'
13066 !      include 'COMMON.INTERACT'
13067 !      include 'COMMON.IOUNITS'
13068 !      include 'COMMON.NAMES'
13069 !      include 'COMMON.TIME1'
13070       integer :: i,j,ii,k
13071       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13072
13073       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13074       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13075       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13076
13077       Uconst_back=0.0d0
13078       do i=1,nres
13079         dutheta(i)=0.0d0
13080         dugamma(i)=0.0d0
13081         do j=1,3
13082           duscdiff(j,i)=0.0d0
13083           duscdiffx(j,i)=0.0d0
13084         enddo
13085       enddo
13086       do i=1,nfrag_back
13087         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13088 !
13089 ! Deviations from theta angles
13090 !
13091         utheta_i=0.0d0
13092         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13093           dtheta_i=theta(j)-thetaref(j)
13094           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13095           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13096         enddo
13097         utheta(i)=utheta_i/(ii-1)
13098 !
13099 ! Deviations from gamma angles
13100 !
13101         ugamma_i=0.0d0
13102         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13103           dgamma_i=pinorm(phi(j)-phiref(j))
13104 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13105           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13106           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13107 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13108         enddo
13109         ugamma(i)=ugamma_i/(ii-2)
13110 !
13111 ! Deviations from local SC geometry
13112 !
13113         uscdiff(i)=0.0d0
13114         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13115           dxx=xxtab(j)-xxref(j)
13116           dyy=yytab(j)-yyref(j)
13117           dzz=zztab(j)-zzref(j)
13118           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13119           do k=1,3
13120             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13121              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13122              (ii-1)
13123             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13124              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13125              (ii-1)
13126             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13127            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13128             /(ii-1)
13129           enddo
13130 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13131 !     &      xxref(j),yyref(j),zzref(j)
13132         enddo
13133         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13134 !        write (iout,*) i," uscdiff",uscdiff(i)
13135 !
13136 ! Put together deviations from local geometry
13137 !
13138         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13139           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13140 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13141 !     &   " uconst_back",uconst_back
13142         utheta(i)=dsqrt(utheta(i))
13143         ugamma(i)=dsqrt(ugamma(i))
13144         uscdiff(i)=dsqrt(uscdiff(i))
13145       enddo
13146       return
13147       end subroutine Econstr_back
13148 !-----------------------------------------------------------------------------
13149 ! energy_p_new-sep_barrier.F
13150 !-----------------------------------------------------------------------------
13151       real(kind=8) function sscale(r)
13152 !      include "COMMON.SPLITELE"
13153       real(kind=8) :: r,gamm
13154       if(r.lt.r_cut-rlamb) then
13155         sscale=1.0d0
13156       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13157         gamm=(r-(r_cut-rlamb))/rlamb
13158         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13159       else
13160         sscale=0d0
13161       endif
13162       return
13163       end function sscale
13164       real(kind=8) function sscale_grad(r)
13165 !      include "COMMON.SPLITELE"
13166       real(kind=8) :: r,gamm
13167       if(r.lt.r_cut-rlamb) then
13168         sscale_grad=0.0d0
13169       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13170         gamm=(r-(r_cut-rlamb))/rlamb
13171         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13172       else
13173         sscale_grad=0d0
13174       endif
13175       return
13176       end function sscale_grad
13177
13178 !!!!!!!!!! PBCSCALE
13179       real(kind=8) function sscale_ele(r)
13180 !      include "COMMON.SPLITELE"
13181       real(kind=8) :: r,gamm
13182       if(r.lt.r_cut_ele-rlamb_ele) then
13183         sscale_ele=1.0d0
13184       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13185         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13186         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13187       else
13188         sscale_ele=0d0
13189       endif
13190       return
13191       end function sscale_ele
13192
13193       real(kind=8)  function sscagrad_ele(r)
13194       real(kind=8) :: r,gamm
13195 !      include "COMMON.SPLITELE"
13196       if(r.lt.r_cut_ele-rlamb_ele) then
13197         sscagrad_ele=0.0d0
13198       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13199         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13200         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13201       else
13202         sscagrad_ele=0.0d0
13203       endif
13204       return
13205       end function sscagrad_ele
13206       real(kind=8) function sscalelip(r)
13207       real(kind=8) r,gamm
13208         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13209       return
13210       end function sscalelip
13211 !C-----------------------------------------------------------------------
13212       real(kind=8) function sscagradlip(r)
13213       real(kind=8) r,gamm
13214         sscagradlip=r*(6.0d0*r-6.0d0)
13215       return
13216       end function sscagradlip
13217
13218 !!!!!!!!!!!!!!!
13219 !-----------------------------------------------------------------------------
13220       subroutine elj_long(evdw)
13221 !
13222 ! This subroutine calculates the interaction energy of nonbonded side chains
13223 ! assuming the LJ potential of interaction.
13224 !
13225 !      implicit real*8 (a-h,o-z)
13226 !      include 'DIMENSIONS'
13227 !      include 'COMMON.GEO'
13228 !      include 'COMMON.VAR'
13229 !      include 'COMMON.LOCAL'
13230 !      include 'COMMON.CHAIN'
13231 !      include 'COMMON.DERIV'
13232 !      include 'COMMON.INTERACT'
13233 !      include 'COMMON.TORSION'
13234 !      include 'COMMON.SBRIDGE'
13235 !      include 'COMMON.NAMES'
13236 !      include 'COMMON.IOUNITS'
13237 !      include 'COMMON.CONTACTS'
13238       real(kind=8),parameter :: accur=1.0d-10
13239       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13240 !el local variables
13241       integer :: i,iint,j,k,itypi,itypi1,itypj
13242       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13243       real(kind=8) :: e1,e2,evdwij,evdw
13244 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13245       evdw=0.0D0
13246       do i=iatsc_s,iatsc_e
13247         itypi=itype(i,1)
13248         if (itypi.eq.ntyp1) cycle
13249         itypi1=itype(i+1,1)
13250         xi=c(1,nres+i)
13251         yi=c(2,nres+i)
13252         zi=c(3,nres+i)
13253 !
13254 ! Calculate SC interaction energy.
13255 !
13256         do iint=1,nint_gr(i)
13257 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13258 !d   &                  'iend=',iend(i,iint)
13259           do j=istart(i,iint),iend(i,iint)
13260             itypj=itype(j,1)
13261             if (itypj.eq.ntyp1) cycle
13262             xj=c(1,nres+j)-xi
13263             yj=c(2,nres+j)-yi
13264             zj=c(3,nres+j)-zi
13265             rij=xj*xj+yj*yj+zj*zj
13266             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13267             if (sss.lt.1.0d0) then
13268               rrij=1.0D0/rij
13269               eps0ij=eps(itypi,itypj)
13270               fac=rrij**expon2
13271               e1=fac*fac*aa_aq(itypi,itypj)
13272               e2=fac*bb_aq(itypi,itypj)
13273               evdwij=e1+e2
13274               evdw=evdw+(1.0d0-sss)*evdwij
13275 !
13276 ! Calculate the components of the gradient in DC and X
13277 !
13278               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13279               gg(1)=xj*fac
13280               gg(2)=yj*fac
13281               gg(3)=zj*fac
13282               do k=1,3
13283                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13284                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13285                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13286                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13287               enddo
13288             endif
13289           enddo      ! j
13290         enddo        ! iint
13291       enddo          ! i
13292       do i=1,nct
13293         do j=1,3
13294           gvdwc(j,i)=expon*gvdwc(j,i)
13295           gvdwx(j,i)=expon*gvdwx(j,i)
13296         enddo
13297       enddo
13298 !******************************************************************************
13299 !
13300 !                              N O T E !!!
13301 !
13302 ! To save time, the factor of EXPON has been extracted from ALL components
13303 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13304 ! use!
13305 !
13306 !******************************************************************************
13307       return
13308       end subroutine elj_long
13309 !-----------------------------------------------------------------------------
13310       subroutine elj_short(evdw)
13311 !
13312 ! This subroutine calculates the interaction energy of nonbonded side chains
13313 ! assuming the LJ potential of interaction.
13314 !
13315 !      implicit real*8 (a-h,o-z)
13316 !      include 'DIMENSIONS'
13317 !      include 'COMMON.GEO'
13318 !      include 'COMMON.VAR'
13319 !      include 'COMMON.LOCAL'
13320 !      include 'COMMON.CHAIN'
13321 !      include 'COMMON.DERIV'
13322 !      include 'COMMON.INTERACT'
13323 !      include 'COMMON.TORSION'
13324 !      include 'COMMON.SBRIDGE'
13325 !      include 'COMMON.NAMES'
13326 !      include 'COMMON.IOUNITS'
13327 !      include 'COMMON.CONTACTS'
13328       real(kind=8),parameter :: accur=1.0d-10
13329       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13330 !el local variables
13331       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13332       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13333       real(kind=8) :: e1,e2,evdwij,evdw
13334 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13335       evdw=0.0D0
13336       do i=iatsc_s,iatsc_e
13337         itypi=itype(i,1)
13338         if (itypi.eq.ntyp1) cycle
13339         itypi1=itype(i+1,1)
13340         xi=c(1,nres+i)
13341         yi=c(2,nres+i)
13342         zi=c(3,nres+i)
13343 ! Change 12/1/95
13344         num_conti=0
13345 !
13346 ! Calculate SC interaction energy.
13347 !
13348         do iint=1,nint_gr(i)
13349 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13350 !d   &                  'iend=',iend(i,iint)
13351           do j=istart(i,iint),iend(i,iint)
13352             itypj=itype(j,1)
13353             if (itypj.eq.ntyp1) cycle
13354             xj=c(1,nres+j)-xi
13355             yj=c(2,nres+j)-yi
13356             zj=c(3,nres+j)-zi
13357 ! Change 12/1/95 to calculate four-body interactions
13358             rij=xj*xj+yj*yj+zj*zj
13359             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13360             if (sss.gt.0.0d0) then
13361               rrij=1.0D0/rij
13362               eps0ij=eps(itypi,itypj)
13363               fac=rrij**expon2
13364               e1=fac*fac*aa_aq(itypi,itypj)
13365               e2=fac*bb_aq(itypi,itypj)
13366               evdwij=e1+e2
13367               evdw=evdw+sss*evdwij
13368 !
13369 ! Calculate the components of the gradient in DC and X
13370 !
13371               fac=-rrij*(e1+evdwij)*sss
13372               gg(1)=xj*fac
13373               gg(2)=yj*fac
13374               gg(3)=zj*fac
13375               do k=1,3
13376                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13377                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13378                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13379                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13380               enddo
13381             endif
13382           enddo      ! j
13383         enddo        ! iint
13384       enddo          ! i
13385       do i=1,nct
13386         do j=1,3
13387           gvdwc(j,i)=expon*gvdwc(j,i)
13388           gvdwx(j,i)=expon*gvdwx(j,i)
13389         enddo
13390       enddo
13391 !******************************************************************************
13392 !
13393 !                              N O T E !!!
13394 !
13395 ! To save time, the factor of EXPON has been extracted from ALL components
13396 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13397 ! use!
13398 !
13399 !******************************************************************************
13400       return
13401       end subroutine elj_short
13402 !-----------------------------------------------------------------------------
13403       subroutine eljk_long(evdw)
13404 !
13405 ! This subroutine calculates the interaction energy of nonbonded side chains
13406 ! assuming the LJK potential of interaction.
13407 !
13408 !      implicit real*8 (a-h,o-z)
13409 !      include 'DIMENSIONS'
13410 !      include 'COMMON.GEO'
13411 !      include 'COMMON.VAR'
13412 !      include 'COMMON.LOCAL'
13413 !      include 'COMMON.CHAIN'
13414 !      include 'COMMON.DERIV'
13415 !      include 'COMMON.INTERACT'
13416 !      include 'COMMON.IOUNITS'
13417 !      include 'COMMON.NAMES'
13418       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13419       logical :: scheck
13420 !el local variables
13421       integer :: i,iint,j,k,itypi,itypi1,itypj
13422       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13423                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13424 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13425       evdw=0.0D0
13426       do i=iatsc_s,iatsc_e
13427         itypi=itype(i,1)
13428         if (itypi.eq.ntyp1) cycle
13429         itypi1=itype(i+1,1)
13430         xi=c(1,nres+i)
13431         yi=c(2,nres+i)
13432         zi=c(3,nres+i)
13433 !
13434 ! Calculate SC interaction energy.
13435 !
13436         do iint=1,nint_gr(i)
13437           do j=istart(i,iint),iend(i,iint)
13438             itypj=itype(j,1)
13439             if (itypj.eq.ntyp1) cycle
13440             xj=c(1,nres+j)-xi
13441             yj=c(2,nres+j)-yi
13442             zj=c(3,nres+j)-zi
13443             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13444             fac_augm=rrij**expon
13445             e_augm=augm(itypi,itypj)*fac_augm
13446             r_inv_ij=dsqrt(rrij)
13447             rij=1.0D0/r_inv_ij
13448             sss=sscale(rij/sigma(itypi,itypj))
13449             if (sss.lt.1.0d0) then
13450               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13451               fac=r_shift_inv**expon
13452               e1=fac*fac*aa_aq(itypi,itypj)
13453               e2=fac*bb_aq(itypi,itypj)
13454               evdwij=e_augm+e1+e2
13455 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13456 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13457 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13458 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13459 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13460 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13461 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13462               evdw=evdw+(1.0d0-sss)*evdwij
13463 !
13464 ! Calculate the components of the gradient in DC and X
13465 !
13466               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13467               fac=fac*(1.0d0-sss)
13468               gg(1)=xj*fac
13469               gg(2)=yj*fac
13470               gg(3)=zj*fac
13471               do k=1,3
13472                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13473                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13474                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13475                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13476               enddo
13477             endif
13478           enddo      ! j
13479         enddo        ! iint
13480       enddo          ! i
13481       do i=1,nct
13482         do j=1,3
13483           gvdwc(j,i)=expon*gvdwc(j,i)
13484           gvdwx(j,i)=expon*gvdwx(j,i)
13485         enddo
13486       enddo
13487       return
13488       end subroutine eljk_long
13489 !-----------------------------------------------------------------------------
13490       subroutine eljk_short(evdw)
13491 !
13492 ! This subroutine calculates the interaction energy of nonbonded side chains
13493 ! assuming the LJK potential of interaction.
13494 !
13495 !      implicit real*8 (a-h,o-z)
13496 !      include 'DIMENSIONS'
13497 !      include 'COMMON.GEO'
13498 !      include 'COMMON.VAR'
13499 !      include 'COMMON.LOCAL'
13500 !      include 'COMMON.CHAIN'
13501 !      include 'COMMON.DERIV'
13502 !      include 'COMMON.INTERACT'
13503 !      include 'COMMON.IOUNITS'
13504 !      include 'COMMON.NAMES'
13505       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13506       logical :: scheck
13507 !el local variables
13508       integer :: i,iint,j,k,itypi,itypi1,itypj
13509       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13510                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13511 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13512       evdw=0.0D0
13513       do i=iatsc_s,iatsc_e
13514         itypi=itype(i,1)
13515         if (itypi.eq.ntyp1) cycle
13516         itypi1=itype(i+1,1)
13517         xi=c(1,nres+i)
13518         yi=c(2,nres+i)
13519         zi=c(3,nres+i)
13520 !
13521 ! Calculate SC interaction energy.
13522 !
13523         do iint=1,nint_gr(i)
13524           do j=istart(i,iint),iend(i,iint)
13525             itypj=itype(j,1)
13526             if (itypj.eq.ntyp1) cycle
13527             xj=c(1,nres+j)-xi
13528             yj=c(2,nres+j)-yi
13529             zj=c(3,nres+j)-zi
13530             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13531             fac_augm=rrij**expon
13532             e_augm=augm(itypi,itypj)*fac_augm
13533             r_inv_ij=dsqrt(rrij)
13534             rij=1.0D0/r_inv_ij
13535             sss=sscale(rij/sigma(itypi,itypj))
13536             if (sss.gt.0.0d0) then
13537               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13538               fac=r_shift_inv**expon
13539               e1=fac*fac*aa_aq(itypi,itypj)
13540               e2=fac*bb_aq(itypi,itypj)
13541               evdwij=e_augm+e1+e2
13542 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13543 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13544 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13545 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13546 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13547 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13548 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13549               evdw=evdw+sss*evdwij
13550 !
13551 ! Calculate the components of the gradient in DC and X
13552 !
13553               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13554               fac=fac*sss
13555               gg(1)=xj*fac
13556               gg(2)=yj*fac
13557               gg(3)=zj*fac
13558               do k=1,3
13559                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13560                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13561                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13562                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13563               enddo
13564             endif
13565           enddo      ! j
13566         enddo        ! iint
13567       enddo          ! i
13568       do i=1,nct
13569         do j=1,3
13570           gvdwc(j,i)=expon*gvdwc(j,i)
13571           gvdwx(j,i)=expon*gvdwx(j,i)
13572         enddo
13573       enddo
13574       return
13575       end subroutine eljk_short
13576 !-----------------------------------------------------------------------------
13577       subroutine ebp_long(evdw)
13578 !
13579 ! This subroutine calculates the interaction energy of nonbonded side chains
13580 ! assuming the Berne-Pechukas potential of interaction.
13581 !
13582       use calc_data
13583 !      implicit real*8 (a-h,o-z)
13584 !      include 'DIMENSIONS'
13585 !      include 'COMMON.GEO'
13586 !      include 'COMMON.VAR'
13587 !      include 'COMMON.LOCAL'
13588 !      include 'COMMON.CHAIN'
13589 !      include 'COMMON.DERIV'
13590 !      include 'COMMON.NAMES'
13591 !      include 'COMMON.INTERACT'
13592 !      include 'COMMON.IOUNITS'
13593 !      include 'COMMON.CALC'
13594       use comm_srutu
13595 !el      integer :: icall
13596 !el      common /srutu/ icall
13597 !     double precision rrsave(maxdim)
13598       logical :: lprn
13599 !el local variables
13600       integer :: iint,itypi,itypi1,itypj
13601       real(kind=8) :: rrij,xi,yi,zi,fac
13602       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13603       evdw=0.0D0
13604 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13605       evdw=0.0D0
13606 !     if (icall.eq.0) then
13607 !       lprn=.true.
13608 !     else
13609         lprn=.false.
13610 !     endif
13611 !el      ind=0
13612       do i=iatsc_s,iatsc_e
13613         itypi=itype(i,1)
13614         if (itypi.eq.ntyp1) cycle
13615         itypi1=itype(i+1,1)
13616         xi=c(1,nres+i)
13617         yi=c(2,nres+i)
13618         zi=c(3,nres+i)
13619         dxi=dc_norm(1,nres+i)
13620         dyi=dc_norm(2,nres+i)
13621         dzi=dc_norm(3,nres+i)
13622 !        dsci_inv=dsc_inv(itypi)
13623         dsci_inv=vbld_inv(i+nres)
13624 !
13625 ! Calculate SC interaction energy.
13626 !
13627         do iint=1,nint_gr(i)
13628           do j=istart(i,iint),iend(i,iint)
13629 !el            ind=ind+1
13630             itypj=itype(j,1)
13631             if (itypj.eq.ntyp1) cycle
13632 !            dscj_inv=dsc_inv(itypj)
13633             dscj_inv=vbld_inv(j+nres)
13634             chi1=chi(itypi,itypj)
13635             chi2=chi(itypj,itypi)
13636             chi12=chi1*chi2
13637             chip1=chip(itypi)
13638             chip2=chip(itypj)
13639             chip12=chip1*chip2
13640             alf1=alp(itypi)
13641             alf2=alp(itypj)
13642             alf12=0.5D0*(alf1+alf2)
13643             xj=c(1,nres+j)-xi
13644             yj=c(2,nres+j)-yi
13645             zj=c(3,nres+j)-zi
13646             dxj=dc_norm(1,nres+j)
13647             dyj=dc_norm(2,nres+j)
13648             dzj=dc_norm(3,nres+j)
13649             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13650             rij=dsqrt(rrij)
13651             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13652
13653             if (sss.lt.1.0d0) then
13654
13655 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13656               call sc_angular
13657 ! Calculate whole angle-dependent part of epsilon and contributions
13658 ! to its derivatives
13659               fac=(rrij*sigsq)**expon2
13660               e1=fac*fac*aa_aq(itypi,itypj)
13661               e2=fac*bb_aq(itypi,itypj)
13662               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13663               eps2der=evdwij*eps3rt
13664               eps3der=evdwij*eps2rt
13665               evdwij=evdwij*eps2rt*eps3rt
13666               evdw=evdw+evdwij*(1.0d0-sss)
13667               if (lprn) then
13668               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13669               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13670 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13671 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13672 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13673 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13674 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13675 !d     &          evdwij
13676               endif
13677 ! Calculate gradient components.
13678               e1=e1*eps1*eps2rt**2*eps3rt**2
13679               fac=-expon*(e1+evdwij)
13680               sigder=fac/sigsq
13681               fac=rrij*fac
13682 ! Calculate radial part of the gradient
13683               gg(1)=xj*fac
13684               gg(2)=yj*fac
13685               gg(3)=zj*fac
13686 ! Calculate the angular part of the gradient and sum add the contributions
13687 ! to the appropriate components of the Cartesian gradient.
13688               call sc_grad_scale(1.0d0-sss)
13689             endif
13690           enddo      ! j
13691         enddo        ! iint
13692       enddo          ! i
13693 !     stop
13694       return
13695       end subroutine ebp_long
13696 !-----------------------------------------------------------------------------
13697       subroutine ebp_short(evdw)
13698 !
13699 ! This subroutine calculates the interaction energy of nonbonded side chains
13700 ! assuming the Berne-Pechukas potential of interaction.
13701 !
13702       use calc_data
13703 !      implicit real*8 (a-h,o-z)
13704 !      include 'DIMENSIONS'
13705 !      include 'COMMON.GEO'
13706 !      include 'COMMON.VAR'
13707 !      include 'COMMON.LOCAL'
13708 !      include 'COMMON.CHAIN'
13709 !      include 'COMMON.DERIV'
13710 !      include 'COMMON.NAMES'
13711 !      include 'COMMON.INTERACT'
13712 !      include 'COMMON.IOUNITS'
13713 !      include 'COMMON.CALC'
13714       use comm_srutu
13715 !el      integer :: icall
13716 !el      common /srutu/ icall
13717 !     double precision rrsave(maxdim)
13718       logical :: lprn
13719 !el local variables
13720       integer :: iint,itypi,itypi1,itypj
13721       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13722       real(kind=8) :: sss,e1,e2,evdw
13723       evdw=0.0D0
13724 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13725       evdw=0.0D0
13726 !     if (icall.eq.0) then
13727 !       lprn=.true.
13728 !     else
13729         lprn=.false.
13730 !     endif
13731 !el      ind=0
13732       do i=iatsc_s,iatsc_e
13733         itypi=itype(i,1)
13734         if (itypi.eq.ntyp1) cycle
13735         itypi1=itype(i+1,1)
13736         xi=c(1,nres+i)
13737         yi=c(2,nres+i)
13738         zi=c(3,nres+i)
13739         dxi=dc_norm(1,nres+i)
13740         dyi=dc_norm(2,nres+i)
13741         dzi=dc_norm(3,nres+i)
13742 !        dsci_inv=dsc_inv(itypi)
13743         dsci_inv=vbld_inv(i+nres)
13744 !
13745 ! Calculate SC interaction energy.
13746 !
13747         do iint=1,nint_gr(i)
13748           do j=istart(i,iint),iend(i,iint)
13749 !el            ind=ind+1
13750             itypj=itype(j,1)
13751             if (itypj.eq.ntyp1) cycle
13752 !            dscj_inv=dsc_inv(itypj)
13753             dscj_inv=vbld_inv(j+nres)
13754             chi1=chi(itypi,itypj)
13755             chi2=chi(itypj,itypi)
13756             chi12=chi1*chi2
13757             chip1=chip(itypi)
13758             chip2=chip(itypj)
13759             chip12=chip1*chip2
13760             alf1=alp(itypi)
13761             alf2=alp(itypj)
13762             alf12=0.5D0*(alf1+alf2)
13763             xj=c(1,nres+j)-xi
13764             yj=c(2,nres+j)-yi
13765             zj=c(3,nres+j)-zi
13766             dxj=dc_norm(1,nres+j)
13767             dyj=dc_norm(2,nres+j)
13768             dzj=dc_norm(3,nres+j)
13769             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13770             rij=dsqrt(rrij)
13771             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13772
13773             if (sss.gt.0.0d0) then
13774
13775 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13776               call sc_angular
13777 ! Calculate whole angle-dependent part of epsilon and contributions
13778 ! to its derivatives
13779               fac=(rrij*sigsq)**expon2
13780               e1=fac*fac*aa_aq(itypi,itypj)
13781               e2=fac*bb_aq(itypi,itypj)
13782               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13783               eps2der=evdwij*eps3rt
13784               eps3der=evdwij*eps2rt
13785               evdwij=evdwij*eps2rt*eps3rt
13786               evdw=evdw+evdwij*sss
13787               if (lprn) then
13788               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13789               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13790 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13791 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13792 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13793 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13794 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13795 !d     &          evdwij
13796               endif
13797 ! Calculate gradient components.
13798               e1=e1*eps1*eps2rt**2*eps3rt**2
13799               fac=-expon*(e1+evdwij)
13800               sigder=fac/sigsq
13801               fac=rrij*fac
13802 ! Calculate radial part of the gradient
13803               gg(1)=xj*fac
13804               gg(2)=yj*fac
13805               gg(3)=zj*fac
13806 ! Calculate the angular part of the gradient and sum add the contributions
13807 ! to the appropriate components of the Cartesian gradient.
13808               call sc_grad_scale(sss)
13809             endif
13810           enddo      ! j
13811         enddo        ! iint
13812       enddo          ! i
13813 !     stop
13814       return
13815       end subroutine ebp_short
13816 !-----------------------------------------------------------------------------
13817       subroutine egb_long(evdw)
13818 !
13819 ! This subroutine calculates the interaction energy of nonbonded side chains
13820 ! assuming the Gay-Berne potential of interaction.
13821 !
13822       use calc_data
13823 !      implicit real*8 (a-h,o-z)
13824 !      include 'DIMENSIONS'
13825 !      include 'COMMON.GEO'
13826 !      include 'COMMON.VAR'
13827 !      include 'COMMON.LOCAL'
13828 !      include 'COMMON.CHAIN'
13829 !      include 'COMMON.DERIV'
13830 !      include 'COMMON.NAMES'
13831 !      include 'COMMON.INTERACT'
13832 !      include 'COMMON.IOUNITS'
13833 !      include 'COMMON.CALC'
13834 !      include 'COMMON.CONTROL'
13835       logical :: lprn
13836 !el local variables
13837       integer :: iint,itypi,itypi1,itypj,subchap
13838       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13839       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13840       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13841                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13842                     ssgradlipi,ssgradlipj
13843
13844
13845       evdw=0.0D0
13846 !cccc      energy_dec=.false.
13847 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13848       evdw=0.0D0
13849       lprn=.false.
13850 !     if (icall.eq.0) lprn=.false.
13851 !el      ind=0
13852       do i=iatsc_s,iatsc_e
13853         itypi=itype(i,1)
13854         if (itypi.eq.ntyp1) cycle
13855         itypi1=itype(i+1,1)
13856         xi=c(1,nres+i)
13857         yi=c(2,nres+i)
13858         zi=c(3,nres+i)
13859           xi=mod(xi,boxxsize)
13860           if (xi.lt.0) xi=xi+boxxsize
13861           yi=mod(yi,boxysize)
13862           if (yi.lt.0) yi=yi+boxysize
13863           zi=mod(zi,boxzsize)
13864           if (zi.lt.0) zi=zi+boxzsize
13865        if ((zi.gt.bordlipbot)    &
13866         .and.(zi.lt.bordliptop)) then
13867 !C the energy transfer exist
13868         if (zi.lt.buflipbot) then
13869 !C what fraction I am in
13870          fracinbuf=1.0d0-    &
13871              ((zi-bordlipbot)/lipbufthick)
13872 !C lipbufthick is thickenes of lipid buffore
13873          sslipi=sscalelip(fracinbuf)
13874          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13875         elseif (zi.gt.bufliptop) then
13876          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13877          sslipi=sscalelip(fracinbuf)
13878          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13879         else
13880          sslipi=1.0d0
13881          ssgradlipi=0.0
13882         endif
13883        else
13884          sslipi=0.0d0
13885          ssgradlipi=0.0
13886        endif
13887
13888         dxi=dc_norm(1,nres+i)
13889         dyi=dc_norm(2,nres+i)
13890         dzi=dc_norm(3,nres+i)
13891 !        dsci_inv=dsc_inv(itypi)
13892         dsci_inv=vbld_inv(i+nres)
13893 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13894 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13895 !
13896 ! Calculate SC interaction energy.
13897 !
13898         do iint=1,nint_gr(i)
13899           do j=istart(i,iint),iend(i,iint)
13900             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13901 !              call dyn_ssbond_ene(i,j,evdwij)
13902 !              evdw=evdw+evdwij
13903 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13904 !                              'evdw',i,j,evdwij,' ss'
13905 !              if (energy_dec) write (iout,*) &
13906 !                              'evdw',i,j,evdwij,' ss'
13907 !             do k=j+1,iend(i,iint)
13908 !C search over all next residues
13909 !              if (dyn_ss_mask(k)) then
13910 !C check if they are cysteins
13911 !C              write(iout,*) 'k=',k
13912
13913 !c              write(iout,*) "PRZED TRI", evdwij
13914 !               evdwij_przed_tri=evdwij
13915 !              call triple_ssbond_ene(i,j,k,evdwij)
13916 !c               if(evdwij_przed_tri.ne.evdwij) then
13917 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13918 !c               endif
13919
13920 !c              write(iout,*) "PO TRI", evdwij
13921 !C call the energy function that removes the artifical triple disulfide
13922 !C bond the soubroutine is located in ssMD.F
13923 !              evdw=evdw+evdwij
13924               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13925                             'evdw',i,j,evdwij,'tss'
13926 !              endif!dyn_ss_mask(k)
13927 !             enddo! k
13928
13929             ELSE
13930 !el            ind=ind+1
13931             itypj=itype(j,1)
13932             if (itypj.eq.ntyp1) cycle
13933 !            dscj_inv=dsc_inv(itypj)
13934             dscj_inv=vbld_inv(j+nres)
13935 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13936 !     &       1.0d0/vbld(j+nres)
13937 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13938             sig0ij=sigma(itypi,itypj)
13939             chi1=chi(itypi,itypj)
13940             chi2=chi(itypj,itypi)
13941             chi12=chi1*chi2
13942             chip1=chip(itypi)
13943             chip2=chip(itypj)
13944             chip12=chip1*chip2
13945             alf1=alp(itypi)
13946             alf2=alp(itypj)
13947             alf12=0.5D0*(alf1+alf2)
13948             xj=c(1,nres+j)
13949             yj=c(2,nres+j)
13950             zj=c(3,nres+j)
13951 ! Searching for nearest neighbour
13952           xj=mod(xj,boxxsize)
13953           if (xj.lt.0) xj=xj+boxxsize
13954           yj=mod(yj,boxysize)
13955           if (yj.lt.0) yj=yj+boxysize
13956           zj=mod(zj,boxzsize)
13957           if (zj.lt.0) zj=zj+boxzsize
13958        if ((zj.gt.bordlipbot)   &
13959       .and.(zj.lt.bordliptop)) then
13960 !C the energy transfer exist
13961         if (zj.lt.buflipbot) then
13962 !C what fraction I am in
13963          fracinbuf=1.0d0-  &
13964              ((zj-bordlipbot)/lipbufthick)
13965 !C lipbufthick is thickenes of lipid buffore
13966          sslipj=sscalelip(fracinbuf)
13967          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13968         elseif (zj.gt.bufliptop) then
13969          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13970          sslipj=sscalelip(fracinbuf)
13971          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13972         else
13973          sslipj=1.0d0
13974          ssgradlipj=0.0
13975         endif
13976        else
13977          sslipj=0.0d0
13978          ssgradlipj=0.0
13979        endif
13980       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13981        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13982       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13983        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13984
13985           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13986           xj_safe=xj
13987           yj_safe=yj
13988           zj_safe=zj
13989           subchap=0
13990           do xshift=-1,1
13991           do yshift=-1,1
13992           do zshift=-1,1
13993           xj=xj_safe+xshift*boxxsize
13994           yj=yj_safe+yshift*boxysize
13995           zj=zj_safe+zshift*boxzsize
13996           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13997           if(dist_temp.lt.dist_init) then
13998             dist_init=dist_temp
13999             xj_temp=xj
14000             yj_temp=yj
14001             zj_temp=zj
14002             subchap=1
14003           endif
14004           enddo
14005           enddo
14006           enddo
14007           if (subchap.eq.1) then
14008           xj=xj_temp-xi
14009           yj=yj_temp-yi
14010           zj=zj_temp-zi
14011           else
14012           xj=xj_safe-xi
14013           yj=yj_safe-yi
14014           zj=zj_safe-zi
14015           endif
14016
14017             dxj=dc_norm(1,nres+j)
14018             dyj=dc_norm(2,nres+j)
14019             dzj=dc_norm(3,nres+j)
14020             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14021             rij=dsqrt(rrij)
14022             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14023             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
14024             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
14025             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14026             if (sss_ele_cut.le.0.0) cycle
14027             if (sss.lt.1.0d0) then
14028
14029 ! Calculate angle-dependent terms of energy and contributions to their
14030 ! derivatives.
14031               call sc_angular
14032               sigsq=1.0D0/sigsq
14033               sig=sig0ij*dsqrt(sigsq)
14034               rij_shift=1.0D0/rij-sig+sig0ij
14035 ! for diagnostics; uncomment
14036 !              rij_shift=1.2*sig0ij
14037 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14038               if (rij_shift.le.0.0D0) then
14039                 evdw=1.0D20
14040 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14041 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14042 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14043                 return
14044               endif
14045               sigder=-sig*sigsq
14046 !---------------------------------------------------------------
14047               rij_shift=1.0D0/rij_shift
14048               fac=rij_shift**expon
14049               e1=fac*fac*aa
14050               e2=fac*bb
14051               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14052               eps2der=evdwij*eps3rt
14053               eps3der=evdwij*eps2rt
14054 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14055 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14056               evdwij=evdwij*eps2rt*eps3rt
14057               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14058               if (lprn) then
14059               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14060               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14061               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14062                 restyp(itypi,1),i,restyp(itypj,1),j,&
14063                 epsi,sigm,chi1,chi2,chip1,chip2,&
14064                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14065                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14066                 evdwij
14067               endif
14068
14069               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14070                               'evdw',i,j,evdwij
14071 !              if (energy_dec) write (iout,*) &
14072 !                              'evdw',i,j,evdwij,"egb_long"
14073
14074 ! Calculate gradient components.
14075               e1=e1*eps1*eps2rt**2*eps3rt**2
14076               fac=-expon*(e1+evdwij)*rij_shift
14077               sigder=fac*sigder
14078               fac=rij*fac
14079               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14080             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
14081             /sigmaii(itypi,itypj))
14082 !              fac=0.0d0
14083 ! Calculate the radial part of the gradient
14084               gg(1)=xj*fac
14085               gg(2)=yj*fac
14086               gg(3)=zj*fac
14087 ! Calculate angular part of the gradient.
14088               call sc_grad_scale(1.0d0-sss)
14089             ENDIF    !mask_dyn_ss
14090             endif
14091           enddo      ! j
14092         enddo        ! iint
14093       enddo          ! i
14094 !      write (iout,*) "Number of loop steps in EGB:",ind
14095 !ccc      energy_dec=.false.
14096       return
14097       end subroutine egb_long
14098 !-----------------------------------------------------------------------------
14099       subroutine egb_short(evdw)
14100 !
14101 ! This subroutine calculates the interaction energy of nonbonded side chains
14102 ! assuming the Gay-Berne potential of interaction.
14103 !
14104       use calc_data
14105 !      implicit real*8 (a-h,o-z)
14106 !      include 'DIMENSIONS'
14107 !      include 'COMMON.GEO'
14108 !      include 'COMMON.VAR'
14109 !      include 'COMMON.LOCAL'
14110 !      include 'COMMON.CHAIN'
14111 !      include 'COMMON.DERIV'
14112 !      include 'COMMON.NAMES'
14113 !      include 'COMMON.INTERACT'
14114 !      include 'COMMON.IOUNITS'
14115 !      include 'COMMON.CALC'
14116 !      include 'COMMON.CONTROL'
14117       logical :: lprn
14118 !el local variables
14119       integer :: iint,itypi,itypi1,itypj,subchap
14120       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14121       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14122       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14123                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14124                     ssgradlipi,ssgradlipj
14125       evdw=0.0D0
14126 !cccc      energy_dec=.false.
14127 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14128       evdw=0.0D0
14129       lprn=.false.
14130 !     if (icall.eq.0) lprn=.false.
14131 !el      ind=0
14132       do i=iatsc_s,iatsc_e
14133         itypi=itype(i,1)
14134         if (itypi.eq.ntyp1) cycle
14135         itypi1=itype(i+1,1)
14136         xi=c(1,nres+i)
14137         yi=c(2,nres+i)
14138         zi=c(3,nres+i)
14139           xi=mod(xi,boxxsize)
14140           if (xi.lt.0) xi=xi+boxxsize
14141           yi=mod(yi,boxysize)
14142           if (yi.lt.0) yi=yi+boxysize
14143           zi=mod(zi,boxzsize)
14144           if (zi.lt.0) zi=zi+boxzsize
14145        if ((zi.gt.bordlipbot)    &
14146         .and.(zi.lt.bordliptop)) then
14147 !C the energy transfer exist
14148         if (zi.lt.buflipbot) then
14149 !C what fraction I am in
14150          fracinbuf=1.0d0-    &
14151              ((zi-bordlipbot)/lipbufthick)
14152 !C lipbufthick is thickenes of lipid buffore
14153          sslipi=sscalelip(fracinbuf)
14154          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14155         elseif (zi.gt.bufliptop) then
14156          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14157          sslipi=sscalelip(fracinbuf)
14158          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14159         else
14160          sslipi=1.0d0
14161          ssgradlipi=0.0
14162         endif
14163        else
14164          sslipi=0.0d0
14165          ssgradlipi=0.0
14166        endif
14167
14168         dxi=dc_norm(1,nres+i)
14169         dyi=dc_norm(2,nres+i)
14170         dzi=dc_norm(3,nres+i)
14171 !        dsci_inv=dsc_inv(itypi)
14172         dsci_inv=vbld_inv(i+nres)
14173
14174         dxi=dc_norm(1,nres+i)
14175         dyi=dc_norm(2,nres+i)
14176         dzi=dc_norm(3,nres+i)
14177 !        dsci_inv=dsc_inv(itypi)
14178         dsci_inv=vbld_inv(i+nres)
14179 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14180 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14181 !
14182 ! Calculate SC interaction energy.
14183 !
14184         do iint=1,nint_gr(i)
14185           do j=istart(i,iint),iend(i,iint)
14186             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14187               call dyn_ssbond_ene(i,j,evdwij)
14188               evdw=evdw+evdwij
14189               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14190                               'evdw',i,j,evdwij,' ss'
14191              do k=j+1,iend(i,iint)
14192 !C search over all next residues
14193               if (dyn_ss_mask(k)) then
14194 !C check if they are cysteins
14195 !C              write(iout,*) 'k=',k
14196
14197 !c              write(iout,*) "PRZED TRI", evdwij
14198 !               evdwij_przed_tri=evdwij
14199               call triple_ssbond_ene(i,j,k,evdwij)
14200 !c               if(evdwij_przed_tri.ne.evdwij) then
14201 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14202 !c               endif
14203
14204 !c              write(iout,*) "PO TRI", evdwij
14205 !C call the energy function that removes the artifical triple disulfide
14206 !C bond the soubroutine is located in ssMD.F
14207               evdw=evdw+evdwij
14208               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14209                             'evdw',i,j,evdwij,'tss'
14210               endif!dyn_ss_mask(k)
14211              enddo! k
14212
14213 !              if (energy_dec) write (iout,*) &
14214 !                              'evdw',i,j,evdwij,' ss'
14215             ELSE
14216 !el            ind=ind+1
14217             itypj=itype(j,1)
14218             if (itypj.eq.ntyp1) cycle
14219 !            dscj_inv=dsc_inv(itypj)
14220             dscj_inv=vbld_inv(j+nres)
14221 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14222 !     &       1.0d0/vbld(j+nres)
14223 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14224             sig0ij=sigma(itypi,itypj)
14225             chi1=chi(itypi,itypj)
14226             chi2=chi(itypj,itypi)
14227             chi12=chi1*chi2
14228             chip1=chip(itypi)
14229             chip2=chip(itypj)
14230             chip12=chip1*chip2
14231             alf1=alp(itypi)
14232             alf2=alp(itypj)
14233             alf12=0.5D0*(alf1+alf2)
14234 !            xj=c(1,nres+j)-xi
14235 !            yj=c(2,nres+j)-yi
14236 !            zj=c(3,nres+j)-zi
14237             xj=c(1,nres+j)
14238             yj=c(2,nres+j)
14239             zj=c(3,nres+j)
14240 ! Searching for nearest neighbour
14241           xj=mod(xj,boxxsize)
14242           if (xj.lt.0) xj=xj+boxxsize
14243           yj=mod(yj,boxysize)
14244           if (yj.lt.0) yj=yj+boxysize
14245           zj=mod(zj,boxzsize)
14246           if (zj.lt.0) zj=zj+boxzsize
14247        if ((zj.gt.bordlipbot)   &
14248       .and.(zj.lt.bordliptop)) then
14249 !C the energy transfer exist
14250         if (zj.lt.buflipbot) then
14251 !C what fraction I am in
14252          fracinbuf=1.0d0-  &
14253              ((zj-bordlipbot)/lipbufthick)
14254 !C lipbufthick is thickenes of lipid buffore
14255          sslipj=sscalelip(fracinbuf)
14256          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14257         elseif (zj.gt.bufliptop) then
14258          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14259          sslipj=sscalelip(fracinbuf)
14260          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14261         else
14262          sslipj=1.0d0
14263          ssgradlipj=0.0
14264         endif
14265        else
14266          sslipj=0.0d0
14267          ssgradlipj=0.0
14268        endif
14269       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14270        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14271       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14272        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14273
14274           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14275           xj_safe=xj
14276           yj_safe=yj
14277           zj_safe=zj
14278           subchap=0
14279
14280           do xshift=-1,1
14281           do yshift=-1,1
14282           do zshift=-1,1
14283           xj=xj_safe+xshift*boxxsize
14284           yj=yj_safe+yshift*boxysize
14285           zj=zj_safe+zshift*boxzsize
14286           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14287           if(dist_temp.lt.dist_init) then
14288             dist_init=dist_temp
14289             xj_temp=xj
14290             yj_temp=yj
14291             zj_temp=zj
14292             subchap=1
14293           endif
14294           enddo
14295           enddo
14296           enddo
14297           if (subchap.eq.1) then
14298           xj=xj_temp-xi
14299           yj=yj_temp-yi
14300           zj=zj_temp-zi
14301           else
14302           xj=xj_safe-xi
14303           yj=yj_safe-yi
14304           zj=zj_safe-zi
14305           endif
14306
14307             dxj=dc_norm(1,nres+j)
14308             dyj=dc_norm(2,nres+j)
14309             dzj=dc_norm(3,nres+j)
14310             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14311             rij=dsqrt(rrij)
14312             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14313             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14314             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
14315             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
14316             if (sss_ele_cut.le.0.0) cycle
14317
14318             if (sss.gt.0.0d0) then
14319
14320 ! Calculate angle-dependent terms of energy and contributions to their
14321 ! derivatives.
14322               call sc_angular
14323               sigsq=1.0D0/sigsq
14324               sig=sig0ij*dsqrt(sigsq)
14325               rij_shift=1.0D0/rij-sig+sig0ij
14326 ! for diagnostics; uncomment
14327 !              rij_shift=1.2*sig0ij
14328 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14329               if (rij_shift.le.0.0D0) then
14330                 evdw=1.0D20
14331 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14332 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14333 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14334                 return
14335               endif
14336               sigder=-sig*sigsq
14337 !---------------------------------------------------------------
14338               rij_shift=1.0D0/rij_shift
14339               fac=rij_shift**expon
14340               e1=fac*fac*aa
14341               e2=fac*bb
14342               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14343               eps2der=evdwij*eps3rt
14344               eps3der=evdwij*eps2rt
14345 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14346 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14347               evdwij=evdwij*eps2rt*eps3rt
14348               evdw=evdw+evdwij*sss*sss_ele_cut
14349               if (lprn) then
14350               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14351               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14352               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14353                 restyp(itypi,1),i,restyp(itypj,1),j,&
14354                 epsi,sigm,chi1,chi2,chip1,chip2,&
14355                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14356                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14357                 evdwij
14358               endif
14359
14360               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14361                               'evdw',i,j,evdwij
14362 !              if (energy_dec) write (iout,*) &
14363 !                              'evdw',i,j,evdwij,"egb_short"
14364
14365 ! Calculate gradient components.
14366               e1=e1*eps1*eps2rt**2*eps3rt**2
14367               fac=-expon*(e1+evdwij)*rij_shift
14368               sigder=fac*sigder
14369               fac=rij*fac
14370               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14371             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
14372             /sigmaii(itypi,itypj))
14373
14374 !              fac=0.0d0
14375 ! Calculate the radial part of the gradient
14376               gg(1)=xj*fac
14377               gg(2)=yj*fac
14378               gg(3)=zj*fac
14379 ! Calculate angular part of the gradient.
14380               call sc_grad_scale(sss)
14381             endif
14382           ENDIF !mask_dyn_ss
14383           enddo      ! j
14384         enddo        ! iint
14385       enddo          ! i
14386 !      write (iout,*) "Number of loop steps in EGB:",ind
14387 !ccc      energy_dec=.false.
14388       return
14389       end subroutine egb_short
14390 !-----------------------------------------------------------------------------
14391       subroutine egbv_long(evdw)
14392 !
14393 ! This subroutine calculates the interaction energy of nonbonded side chains
14394 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14395 !
14396       use calc_data
14397 !      implicit real*8 (a-h,o-z)
14398 !      include 'DIMENSIONS'
14399 !      include 'COMMON.GEO'
14400 !      include 'COMMON.VAR'
14401 !      include 'COMMON.LOCAL'
14402 !      include 'COMMON.CHAIN'
14403 !      include 'COMMON.DERIV'
14404 !      include 'COMMON.NAMES'
14405 !      include 'COMMON.INTERACT'
14406 !      include 'COMMON.IOUNITS'
14407 !      include 'COMMON.CALC'
14408       use comm_srutu
14409 !el      integer :: icall
14410 !el      common /srutu/ icall
14411       logical :: lprn
14412 !el local variables
14413       integer :: iint,itypi,itypi1,itypj
14414       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14415       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14416       evdw=0.0D0
14417 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14418       evdw=0.0D0
14419       lprn=.false.
14420 !     if (icall.eq.0) lprn=.true.
14421 !el      ind=0
14422       do i=iatsc_s,iatsc_e
14423         itypi=itype(i,1)
14424         if (itypi.eq.ntyp1) cycle
14425         itypi1=itype(i+1,1)
14426         xi=c(1,nres+i)
14427         yi=c(2,nres+i)
14428         zi=c(3,nres+i)
14429         dxi=dc_norm(1,nres+i)
14430         dyi=dc_norm(2,nres+i)
14431         dzi=dc_norm(3,nres+i)
14432 !        dsci_inv=dsc_inv(itypi)
14433         dsci_inv=vbld_inv(i+nres)
14434 !
14435 ! Calculate SC interaction energy.
14436 !
14437         do iint=1,nint_gr(i)
14438           do j=istart(i,iint),iend(i,iint)
14439 !el            ind=ind+1
14440             itypj=itype(j,1)
14441             if (itypj.eq.ntyp1) cycle
14442 !            dscj_inv=dsc_inv(itypj)
14443             dscj_inv=vbld_inv(j+nres)
14444             sig0ij=sigma(itypi,itypj)
14445             r0ij=r0(itypi,itypj)
14446             chi1=chi(itypi,itypj)
14447             chi2=chi(itypj,itypi)
14448             chi12=chi1*chi2
14449             chip1=chip(itypi)
14450             chip2=chip(itypj)
14451             chip12=chip1*chip2
14452             alf1=alp(itypi)
14453             alf2=alp(itypj)
14454             alf12=0.5D0*(alf1+alf2)
14455             xj=c(1,nres+j)-xi
14456             yj=c(2,nres+j)-yi
14457             zj=c(3,nres+j)-zi
14458             dxj=dc_norm(1,nres+j)
14459             dyj=dc_norm(2,nres+j)
14460             dzj=dc_norm(3,nres+j)
14461             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14462             rij=dsqrt(rrij)
14463
14464             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14465
14466             if (sss.lt.1.0d0) then
14467
14468 ! Calculate angle-dependent terms of energy and contributions to their
14469 ! derivatives.
14470               call sc_angular
14471               sigsq=1.0D0/sigsq
14472               sig=sig0ij*dsqrt(sigsq)
14473               rij_shift=1.0D0/rij-sig+r0ij
14474 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14475               if (rij_shift.le.0.0D0) then
14476                 evdw=1.0D20
14477                 return
14478               endif
14479               sigder=-sig*sigsq
14480 !---------------------------------------------------------------
14481               rij_shift=1.0D0/rij_shift
14482               fac=rij_shift**expon
14483               e1=fac*fac*aa_aq(itypi,itypj)
14484               e2=fac*bb_aq(itypi,itypj)
14485               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14486               eps2der=evdwij*eps3rt
14487               eps3der=evdwij*eps2rt
14488               fac_augm=rrij**expon
14489               e_augm=augm(itypi,itypj)*fac_augm
14490               evdwij=evdwij*eps2rt*eps3rt
14491               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14492               if (lprn) then
14493               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14494               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14495               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14496                 restyp(itypi,1),i,restyp(itypj,1),j,&
14497                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14498                 chi1,chi2,chip1,chip2,&
14499                 eps1,eps2rt**2,eps3rt**2,&
14500                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14501                 evdwij+e_augm
14502               endif
14503 ! Calculate gradient components.
14504               e1=e1*eps1*eps2rt**2*eps3rt**2
14505               fac=-expon*(e1+evdwij)*rij_shift
14506               sigder=fac*sigder
14507               fac=rij*fac-2*expon*rrij*e_augm
14508 ! Calculate the radial part of the gradient
14509               gg(1)=xj*fac
14510               gg(2)=yj*fac
14511               gg(3)=zj*fac
14512 ! Calculate angular part of the gradient.
14513               call sc_grad_scale(1.0d0-sss)
14514             endif
14515           enddo      ! j
14516         enddo        ! iint
14517       enddo          ! i
14518       end subroutine egbv_long
14519 !-----------------------------------------------------------------------------
14520       subroutine egbv_short(evdw)
14521 !
14522 ! This subroutine calculates the interaction energy of nonbonded side chains
14523 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14524 !
14525       use calc_data
14526 !      implicit real*8 (a-h,o-z)
14527 !      include 'DIMENSIONS'
14528 !      include 'COMMON.GEO'
14529 !      include 'COMMON.VAR'
14530 !      include 'COMMON.LOCAL'
14531 !      include 'COMMON.CHAIN'
14532 !      include 'COMMON.DERIV'
14533 !      include 'COMMON.NAMES'
14534 !      include 'COMMON.INTERACT'
14535 !      include 'COMMON.IOUNITS'
14536 !      include 'COMMON.CALC'
14537       use comm_srutu
14538 !el      integer :: icall
14539 !el      common /srutu/ icall
14540       logical :: lprn
14541 !el local variables
14542       integer :: iint,itypi,itypi1,itypj
14543       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14544       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14545       evdw=0.0D0
14546 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14547       evdw=0.0D0
14548       lprn=.false.
14549 !     if (icall.eq.0) lprn=.true.
14550 !el      ind=0
14551       do i=iatsc_s,iatsc_e
14552         itypi=itype(i,1)
14553         if (itypi.eq.ntyp1) cycle
14554         itypi1=itype(i+1,1)
14555         xi=c(1,nres+i)
14556         yi=c(2,nres+i)
14557         zi=c(3,nres+i)
14558         dxi=dc_norm(1,nres+i)
14559         dyi=dc_norm(2,nres+i)
14560         dzi=dc_norm(3,nres+i)
14561 !        dsci_inv=dsc_inv(itypi)
14562         dsci_inv=vbld_inv(i+nres)
14563 !
14564 ! Calculate SC interaction energy.
14565 !
14566         do iint=1,nint_gr(i)
14567           do j=istart(i,iint),iend(i,iint)
14568 !el            ind=ind+1
14569             itypj=itype(j,1)
14570             if (itypj.eq.ntyp1) cycle
14571 !            dscj_inv=dsc_inv(itypj)
14572             dscj_inv=vbld_inv(j+nres)
14573             sig0ij=sigma(itypi,itypj)
14574             r0ij=r0(itypi,itypj)
14575             chi1=chi(itypi,itypj)
14576             chi2=chi(itypj,itypi)
14577             chi12=chi1*chi2
14578             chip1=chip(itypi)
14579             chip2=chip(itypj)
14580             chip12=chip1*chip2
14581             alf1=alp(itypi)
14582             alf2=alp(itypj)
14583             alf12=0.5D0*(alf1+alf2)
14584             xj=c(1,nres+j)-xi
14585             yj=c(2,nres+j)-yi
14586             zj=c(3,nres+j)-zi
14587             dxj=dc_norm(1,nres+j)
14588             dyj=dc_norm(2,nres+j)
14589             dzj=dc_norm(3,nres+j)
14590             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14591             rij=dsqrt(rrij)
14592
14593             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14594
14595             if (sss.gt.0.0d0) then
14596
14597 ! Calculate angle-dependent terms of energy and contributions to their
14598 ! derivatives.
14599               call sc_angular
14600               sigsq=1.0D0/sigsq
14601               sig=sig0ij*dsqrt(sigsq)
14602               rij_shift=1.0D0/rij-sig+r0ij
14603 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14604               if (rij_shift.le.0.0D0) then
14605                 evdw=1.0D20
14606                 return
14607               endif
14608               sigder=-sig*sigsq
14609 !---------------------------------------------------------------
14610               rij_shift=1.0D0/rij_shift
14611               fac=rij_shift**expon
14612               e1=fac*fac*aa_aq(itypi,itypj)
14613               e2=fac*bb_aq(itypi,itypj)
14614               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14615               eps2der=evdwij*eps3rt
14616               eps3der=evdwij*eps2rt
14617               fac_augm=rrij**expon
14618               e_augm=augm(itypi,itypj)*fac_augm
14619               evdwij=evdwij*eps2rt*eps3rt
14620               evdw=evdw+(evdwij+e_augm)*sss
14621               if (lprn) then
14622               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14623               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14624               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14625                 restyp(itypi,1),i,restyp(itypj,1),j,&
14626                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14627                 chi1,chi2,chip1,chip2,&
14628                 eps1,eps2rt**2,eps3rt**2,&
14629                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14630                 evdwij+e_augm
14631               endif
14632 ! Calculate gradient components.
14633               e1=e1*eps1*eps2rt**2*eps3rt**2
14634               fac=-expon*(e1+evdwij)*rij_shift
14635               sigder=fac*sigder
14636               fac=rij*fac-2*expon*rrij*e_augm
14637 ! Calculate the radial part of the gradient
14638               gg(1)=xj*fac
14639               gg(2)=yj*fac
14640               gg(3)=zj*fac
14641 ! Calculate angular part of the gradient.
14642               call sc_grad_scale(sss)
14643             endif
14644           enddo      ! j
14645         enddo        ! iint
14646       enddo          ! i
14647       end subroutine egbv_short
14648 !-----------------------------------------------------------------------------
14649       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14650 !
14651 ! This subroutine calculates the average interaction energy and its gradient
14652 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14653 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14654 ! The potential depends both on the distance of peptide-group centers and on
14655 ! the orientation of the CA-CA virtual bonds.
14656 !
14657 !      implicit real*8 (a-h,o-z)
14658
14659       use comm_locel
14660 #ifdef MPI
14661       include 'mpif.h'
14662 #endif
14663 !      include 'DIMENSIONS'
14664 !      include 'COMMON.CONTROL'
14665 !      include 'COMMON.SETUP'
14666 !      include 'COMMON.IOUNITS'
14667 !      include 'COMMON.GEO'
14668 !      include 'COMMON.VAR'
14669 !      include 'COMMON.LOCAL'
14670 !      include 'COMMON.CHAIN'
14671 !      include 'COMMON.DERIV'
14672 !      include 'COMMON.INTERACT'
14673 !      include 'COMMON.CONTACTS'
14674 !      include 'COMMON.TORSION'
14675 !      include 'COMMON.VECTORS'
14676 !      include 'COMMON.FFIELD'
14677 !      include 'COMMON.TIME1'
14678       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14679       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14680       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14681 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14682       real(kind=8),dimension(4) :: muij
14683 !el      integer :: num_conti,j1,j2
14684 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14685 !el                   dz_normi,xmedi,ymedi,zmedi
14686 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14687 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14688 !el          num_conti,j1,j2
14689 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14690 #ifdef MOMENT
14691       real(kind=8) :: scal_el=1.0d0
14692 #else
14693       real(kind=8) :: scal_el=0.5d0
14694 #endif
14695 ! 12/13/98
14696 ! 13-go grudnia roku pamietnego...
14697       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14698                                              0.0d0,1.0d0,0.0d0,&
14699                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14700 !el local variables
14701       integer :: i,j,k
14702       real(kind=8) :: fac
14703       real(kind=8) :: dxj,dyj,dzj
14704       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14705
14706 !      allocate(num_cont_hb(nres)) !(maxres)
14707 !d      write(iout,*) 'In EELEC'
14708 !d      do i=1,nloctyp
14709 !d        write(iout,*) 'Type',i
14710 !d        write(iout,*) 'B1',B1(:,i)
14711 !d        write(iout,*) 'B2',B2(:,i)
14712 !d        write(iout,*) 'CC',CC(:,:,i)
14713 !d        write(iout,*) 'DD',DD(:,:,i)
14714 !d        write(iout,*) 'EE',EE(:,:,i)
14715 !d      enddo
14716 !d      call check_vecgrad
14717 !d      stop
14718       if (icheckgrad.eq.1) then
14719         do i=1,nres-1
14720           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14721           do k=1,3
14722             dc_norm(k,i)=dc(k,i)*fac
14723           enddo
14724 !          write (iout,*) 'i',i,' fac',fac
14725         enddo
14726       endif
14727       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14728           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14729           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14730 !        call vec_and_deriv
14731 #ifdef TIMING
14732         time01=MPI_Wtime()
14733 #endif
14734 !        print *, "before set matrices"
14735         call set_matrices
14736 !        print *,"after set martices"
14737 #ifdef TIMING
14738         time_mat=time_mat+MPI_Wtime()-time01
14739 #endif
14740       endif
14741 !d      do i=1,nres-1
14742 !d        write (iout,*) 'i=',i
14743 !d        do k=1,3
14744 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14745 !d        enddo
14746 !d        do k=1,3
14747 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14748 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14749 !d        enddo
14750 !d      enddo
14751       t_eelecij=0.0d0
14752       ees=0.0D0
14753       evdw1=0.0D0
14754       eel_loc=0.0d0
14755       eello_turn3=0.0d0
14756       eello_turn4=0.0d0
14757 !el      ind=0
14758       do i=1,nres
14759         num_cont_hb(i)=0
14760       enddo
14761 !d      print '(a)','Enter EELEC'
14762 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14763 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14764 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14765       do i=1,nres
14766         gel_loc_loc(i)=0.0d0
14767         gcorr_loc(i)=0.0d0
14768       enddo
14769 !
14770 !
14771 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14772 !
14773 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14774 !
14775       do i=iturn3_start,iturn3_end
14776         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14777         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14778         dxi=dc(1,i)
14779         dyi=dc(2,i)
14780         dzi=dc(3,i)
14781         dx_normi=dc_norm(1,i)
14782         dy_normi=dc_norm(2,i)
14783         dz_normi=dc_norm(3,i)
14784         xmedi=c(1,i)+0.5d0*dxi
14785         ymedi=c(2,i)+0.5d0*dyi
14786         zmedi=c(3,i)+0.5d0*dzi
14787           xmedi=dmod(xmedi,boxxsize)
14788           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14789           ymedi=dmod(ymedi,boxysize)
14790           if (ymedi.lt.0) ymedi=ymedi+boxysize
14791           zmedi=dmod(zmedi,boxzsize)
14792           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14793         num_conti=0
14794         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14795         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14796         num_cont_hb(i)=num_conti
14797       enddo
14798       do i=iturn4_start,iturn4_end
14799         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14800           .or. itype(i+3,1).eq.ntyp1 &
14801           .or. itype(i+4,1).eq.ntyp1) cycle
14802         dxi=dc(1,i)
14803         dyi=dc(2,i)
14804         dzi=dc(3,i)
14805         dx_normi=dc_norm(1,i)
14806         dy_normi=dc_norm(2,i)
14807         dz_normi=dc_norm(3,i)
14808         xmedi=c(1,i)+0.5d0*dxi
14809         ymedi=c(2,i)+0.5d0*dyi
14810         zmedi=c(3,i)+0.5d0*dzi
14811           xmedi=dmod(xmedi,boxxsize)
14812           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14813           ymedi=dmod(ymedi,boxysize)
14814           if (ymedi.lt.0) ymedi=ymedi+boxysize
14815           zmedi=dmod(zmedi,boxzsize)
14816           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14817         num_conti=num_cont_hb(i)
14818         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14819         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14820           call eturn4(i,eello_turn4)
14821         num_cont_hb(i)=num_conti
14822       enddo   ! i
14823 !
14824 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14825 !
14826       do i=iatel_s,iatel_e
14827         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14828         dxi=dc(1,i)
14829         dyi=dc(2,i)
14830         dzi=dc(3,i)
14831         dx_normi=dc_norm(1,i)
14832         dy_normi=dc_norm(2,i)
14833         dz_normi=dc_norm(3,i)
14834         xmedi=c(1,i)+0.5d0*dxi
14835         ymedi=c(2,i)+0.5d0*dyi
14836         zmedi=c(3,i)+0.5d0*dzi
14837           xmedi=dmod(xmedi,boxxsize)
14838           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14839           ymedi=dmod(ymedi,boxysize)
14840           if (ymedi.lt.0) ymedi=ymedi+boxysize
14841           zmedi=dmod(zmedi,boxzsize)
14842           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14843 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14844         num_conti=num_cont_hb(i)
14845         do j=ielstart(i),ielend(i)
14846           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14847           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14848         enddo ! j
14849         num_cont_hb(i)=num_conti
14850       enddo   ! i
14851 !      write (iout,*) "Number of loop steps in EELEC:",ind
14852 !d      do i=1,nres
14853 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14854 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14855 !d      enddo
14856 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14857 !cc      eel_loc=eel_loc+eello_turn3
14858 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14859       return
14860       end subroutine eelec_scale
14861 !-----------------------------------------------------------------------------
14862       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14863 !      implicit real*8 (a-h,o-z)
14864
14865       use comm_locel
14866 !      include 'DIMENSIONS'
14867 #ifdef MPI
14868       include "mpif.h"
14869 #endif
14870 !      include 'COMMON.CONTROL'
14871 !      include 'COMMON.IOUNITS'
14872 !      include 'COMMON.GEO'
14873 !      include 'COMMON.VAR'
14874 !      include 'COMMON.LOCAL'
14875 !      include 'COMMON.CHAIN'
14876 !      include 'COMMON.DERIV'
14877 !      include 'COMMON.INTERACT'
14878 !      include 'COMMON.CONTACTS'
14879 !      include 'COMMON.TORSION'
14880 !      include 'COMMON.VECTORS'
14881 !      include 'COMMON.FFIELD'
14882 !      include 'COMMON.TIME1'
14883       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14884       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14885       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14886 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14887       real(kind=8),dimension(4) :: muij
14888       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14889                     dist_temp, dist_init,sss_grad
14890       integer xshift,yshift,zshift
14891
14892 !el      integer :: num_conti,j1,j2
14893 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14894 !el                   dz_normi,xmedi,ymedi,zmedi
14895 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14896 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14897 !el          num_conti,j1,j2
14898 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14899 #ifdef MOMENT
14900       real(kind=8) :: scal_el=1.0d0
14901 #else
14902       real(kind=8) :: scal_el=0.5d0
14903 #endif
14904 ! 12/13/98
14905 ! 13-go grudnia roku pamietnego...
14906       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14907                                              0.0d0,1.0d0,0.0d0,&
14908                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14909 !el local variables
14910       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14911       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14912       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14913       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14914       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14915       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14916       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14917                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14918                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14919                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14920                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14921                   ecosam,ecosbm,ecosgm,ghalf,time00
14922 !      integer :: maxconts
14923 !      maxconts = nres/4
14924 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14925 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14926 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14927 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14928 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14929 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14930 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14931 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14932 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14933 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14934 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14935 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14936 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14937
14938 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14939 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14940
14941 #ifdef MPI
14942           time00=MPI_Wtime()
14943 #endif
14944 !d      write (iout,*) "eelecij",i,j
14945 !el          ind=ind+1
14946           iteli=itel(i)
14947           itelj=itel(j)
14948           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14949           aaa=app(iteli,itelj)
14950           bbb=bpp(iteli,itelj)
14951           ael6i=ael6(iteli,itelj)
14952           ael3i=ael3(iteli,itelj)
14953           dxj=dc(1,j)
14954           dyj=dc(2,j)
14955           dzj=dc(3,j)
14956           dx_normj=dc_norm(1,j)
14957           dy_normj=dc_norm(2,j)
14958           dz_normj=dc_norm(3,j)
14959 !          xj=c(1,j)+0.5D0*dxj-xmedi
14960 !          yj=c(2,j)+0.5D0*dyj-ymedi
14961 !          zj=c(3,j)+0.5D0*dzj-zmedi
14962           xj=c(1,j)+0.5D0*dxj
14963           yj=c(2,j)+0.5D0*dyj
14964           zj=c(3,j)+0.5D0*dzj
14965           xj=mod(xj,boxxsize)
14966           if (xj.lt.0) xj=xj+boxxsize
14967           yj=mod(yj,boxysize)
14968           if (yj.lt.0) yj=yj+boxysize
14969           zj=mod(zj,boxzsize)
14970           if (zj.lt.0) zj=zj+boxzsize
14971       isubchap=0
14972       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14973       xj_safe=xj
14974       yj_safe=yj
14975       zj_safe=zj
14976       do xshift=-1,1
14977       do yshift=-1,1
14978       do zshift=-1,1
14979           xj=xj_safe+xshift*boxxsize
14980           yj=yj_safe+yshift*boxysize
14981           zj=zj_safe+zshift*boxzsize
14982           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14983           if(dist_temp.lt.dist_init) then
14984             dist_init=dist_temp
14985             xj_temp=xj
14986             yj_temp=yj
14987             zj_temp=zj
14988             isubchap=1
14989           endif
14990        enddo
14991        enddo
14992        enddo
14993        if (isubchap.eq.1) then
14994 !C          print *,i,j
14995           xj=xj_temp-xmedi
14996           yj=yj_temp-ymedi
14997           zj=zj_temp-zmedi
14998        else
14999           xj=xj_safe-xmedi
15000           yj=yj_safe-ymedi
15001           zj=zj_safe-zmedi
15002        endif
15003
15004           rij=xj*xj+yj*yj+zj*zj
15005           rrmij=1.0D0/rij
15006           rij=dsqrt(rij)
15007           rmij=1.0D0/rij
15008 ! For extracting the short-range part of Evdwpp
15009           sss=sscale(rij/rpp(iteli,itelj))
15010             sss_ele_cut=sscale_ele(rij)
15011             sss_ele_grad=sscagrad_ele(rij)
15012             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15013 !             sss_ele_cut=1.0d0
15014 !             sss_ele_grad=0.0d0
15015             if (sss_ele_cut.le.0.0) go to 128
15016
15017           r3ij=rrmij*rmij
15018           r6ij=r3ij*r3ij
15019           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15020           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15021           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15022           fac=cosa-3.0D0*cosb*cosg
15023           ev1=aaa*r6ij*r6ij
15024 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15025           if (j.eq.i+2) ev1=scal_el*ev1
15026           ev2=bbb*r6ij
15027           fac3=ael6i*r6ij
15028           fac4=ael3i*r3ij
15029           evdwij=ev1+ev2
15030           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15031           el2=fac4*fac
15032           eesij=el1+el2
15033 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15034           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15035           ees=ees+eesij*sss_ele_cut
15036           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15037 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15038 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15039 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15040 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15041
15042           if (energy_dec) then
15043               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15044               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15045           endif
15046
15047 !
15048 ! Calculate contributions to the Cartesian gradient.
15049 !
15050 #ifdef SPLITELE
15051           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15052           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15053           fac1=fac
15054           erij(1)=xj*rmij
15055           erij(2)=yj*rmij
15056           erij(3)=zj*rmij
15057 !
15058 ! Radial derivatives. First process both termini of the fragment (i,j)
15059 !
15060           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15061           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15062           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15063 !          do k=1,3
15064 !            ghalf=0.5D0*ggg(k)
15065 !            gelc(k,i)=gelc(k,i)+ghalf
15066 !            gelc(k,j)=gelc(k,j)+ghalf
15067 !          enddo
15068 ! 9/28/08 AL Gradient compotents will be summed only at the end
15069           do k=1,3
15070             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15071             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15072           enddo
15073 !
15074 ! Loop over residues i+1 thru j-1.
15075 !
15076 !grad          do k=i+1,j-1
15077 !grad            do l=1,3
15078 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15079 !grad            enddo
15080 !grad          enddo
15081           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15082           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15083           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15084           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15085           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15086           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15087 !          do k=1,3
15088 !            ghalf=0.5D0*ggg(k)
15089 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15090 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15091 !          enddo
15092 ! 9/28/08 AL Gradient compotents will be summed only at the end
15093           do k=1,3
15094             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15095             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15096           enddo
15097 !
15098 ! Loop over residues i+1 thru j-1.
15099 !
15100 !grad          do k=i+1,j-1
15101 !grad            do l=1,3
15102 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15103 !grad            enddo
15104 !grad          enddo
15105 #else
15106           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15107           facel=(el1+eesij)*sss_ele_cut
15108           fac1=fac
15109           fac=-3*rrmij*(facvdw+facvdw+facel)
15110           erij(1)=xj*rmij
15111           erij(2)=yj*rmij
15112           erij(3)=zj*rmij
15113 !
15114 ! Radial derivatives. First process both termini of the fragment (i,j)
15115 !
15116           ggg(1)=fac*xj
15117           ggg(2)=fac*yj
15118           ggg(3)=fac*zj
15119 !          do k=1,3
15120 !            ghalf=0.5D0*ggg(k)
15121 !            gelc(k,i)=gelc(k,i)+ghalf
15122 !            gelc(k,j)=gelc(k,j)+ghalf
15123 !          enddo
15124 ! 9/28/08 AL Gradient compotents will be summed only at the end
15125           do k=1,3
15126             gelc_long(k,j)=gelc(k,j)+ggg(k)
15127             gelc_long(k,i)=gelc(k,i)-ggg(k)
15128           enddo
15129 !
15130 ! Loop over residues i+1 thru j-1.
15131 !
15132 !grad          do k=i+1,j-1
15133 !grad            do l=1,3
15134 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15135 !grad            enddo
15136 !grad          enddo
15137 ! 9/28/08 AL Gradient compotents will be summed only at the end
15138           ggg(1)=facvdw*xj
15139           ggg(2)=facvdw*yj
15140           ggg(3)=facvdw*zj
15141           do k=1,3
15142             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15143             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15144           enddo
15145 #endif
15146 !
15147 ! Angular part
15148 !
15149           ecosa=2.0D0*fac3*fac1+fac4
15150           fac4=-3.0D0*fac4
15151           fac3=-6.0D0*fac3
15152           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15153           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15154           do k=1,3
15155             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15156             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15157           enddo
15158 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15159 !d   &          (dcosg(k),k=1,3)
15160           do k=1,3
15161             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15162           enddo
15163 !          do k=1,3
15164 !            ghalf=0.5D0*ggg(k)
15165 !            gelc(k,i)=gelc(k,i)+ghalf
15166 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15167 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15168 !            gelc(k,j)=gelc(k,j)+ghalf
15169 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15170 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15171 !          enddo
15172 !grad          do k=i+1,j-1
15173 !grad            do l=1,3
15174 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15175 !grad            enddo
15176 !grad          enddo
15177           do k=1,3
15178             gelc(k,i)=gelc(k,i) &
15179                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15180                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15181                      *sss_ele_cut
15182             gelc(k,j)=gelc(k,j) &
15183                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15184                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15185                      *sss_ele_cut
15186             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15187             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15188           enddo
15189           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15190               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15191               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15192 !
15193 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15194 !   energy of a peptide unit is assumed in the form of a second-order
15195 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15196 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15197 !   are computed for EVERY pair of non-contiguous peptide groups.
15198 !
15199           if (j.lt.nres-1) then
15200             j1=j+1
15201             j2=j-1
15202           else
15203             j1=j-1
15204             j2=j-2
15205           endif
15206           kkk=0
15207           do k=1,2
15208             do l=1,2
15209               kkk=kkk+1
15210               muij(kkk)=mu(k,i)*mu(l,j)
15211             enddo
15212           enddo
15213 !d         write (iout,*) 'EELEC: i',i,' j',j
15214 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15215 !d          write(iout,*) 'muij',muij
15216           ury=scalar(uy(1,i),erij)
15217           urz=scalar(uz(1,i),erij)
15218           vry=scalar(uy(1,j),erij)
15219           vrz=scalar(uz(1,j),erij)
15220           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15221           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15222           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15223           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15224           fac=dsqrt(-ael6i)*r3ij
15225           a22=a22*fac
15226           a23=a23*fac
15227           a32=a32*fac
15228           a33=a33*fac
15229 !d          write (iout,'(4i5,4f10.5)')
15230 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15231 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15232 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15233 !d     &      uy(:,j),uz(:,j)
15234 !d          write (iout,'(4f10.5)')
15235 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15236 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15237 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15238 !d           write (iout,'(9f10.5/)')
15239 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15240 ! Derivatives of the elements of A in virtual-bond vectors
15241           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15242           do k=1,3
15243             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15244             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15245             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15246             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15247             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15248             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15249             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15250             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15251             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15252             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15253             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15254             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15255           enddo
15256 ! Compute radial contributions to the gradient
15257           facr=-3.0d0*rrmij
15258           a22der=a22*facr
15259           a23der=a23*facr
15260           a32der=a32*facr
15261           a33der=a33*facr
15262           agg(1,1)=a22der*xj
15263           agg(2,1)=a22der*yj
15264           agg(3,1)=a22der*zj
15265           agg(1,2)=a23der*xj
15266           agg(2,2)=a23der*yj
15267           agg(3,2)=a23der*zj
15268           agg(1,3)=a32der*xj
15269           agg(2,3)=a32der*yj
15270           agg(3,3)=a32der*zj
15271           agg(1,4)=a33der*xj
15272           agg(2,4)=a33der*yj
15273           agg(3,4)=a33der*zj
15274 ! Add the contributions coming from er
15275           fac3=-3.0d0*fac
15276           do k=1,3
15277             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15278             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15279             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15280             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15281           enddo
15282           do k=1,3
15283 ! Derivatives in DC(i)
15284 !grad            ghalf1=0.5d0*agg(k,1)
15285 !grad            ghalf2=0.5d0*agg(k,2)
15286 !grad            ghalf3=0.5d0*agg(k,3)
15287 !grad            ghalf4=0.5d0*agg(k,4)
15288             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15289             -3.0d0*uryg(k,2)*vry)!+ghalf1
15290             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15291             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15292             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15293             -3.0d0*urzg(k,2)*vry)!+ghalf3
15294             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15295             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15296 ! Derivatives in DC(i+1)
15297             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15298             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15299             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15300             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15301             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15302             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15303             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15304             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15305 ! Derivatives in DC(j)
15306             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15307             -3.0d0*vryg(k,2)*ury)!+ghalf1
15308             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15309             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15310             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15311             -3.0d0*vryg(k,2)*urz)!+ghalf3
15312             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15313             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15314 ! Derivatives in DC(j+1) or DC(nres-1)
15315             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15316             -3.0d0*vryg(k,3)*ury)
15317             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15318             -3.0d0*vrzg(k,3)*ury)
15319             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15320             -3.0d0*vryg(k,3)*urz)
15321             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15322             -3.0d0*vrzg(k,3)*urz)
15323 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15324 !grad              do l=1,4
15325 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15326 !grad              enddo
15327 !grad            endif
15328           enddo
15329           acipa(1,1)=a22
15330           acipa(1,2)=a23
15331           acipa(2,1)=a32
15332           acipa(2,2)=a33
15333           a22=-a22
15334           a23=-a23
15335           do l=1,2
15336             do k=1,3
15337               agg(k,l)=-agg(k,l)
15338               aggi(k,l)=-aggi(k,l)
15339               aggi1(k,l)=-aggi1(k,l)
15340               aggj(k,l)=-aggj(k,l)
15341               aggj1(k,l)=-aggj1(k,l)
15342             enddo
15343           enddo
15344           if (j.lt.nres-1) then
15345             a22=-a22
15346             a32=-a32
15347             do l=1,3,2
15348               do k=1,3
15349                 agg(k,l)=-agg(k,l)
15350                 aggi(k,l)=-aggi(k,l)
15351                 aggi1(k,l)=-aggi1(k,l)
15352                 aggj(k,l)=-aggj(k,l)
15353                 aggj1(k,l)=-aggj1(k,l)
15354               enddo
15355             enddo
15356           else
15357             a22=-a22
15358             a23=-a23
15359             a32=-a32
15360             a33=-a33
15361             do l=1,4
15362               do k=1,3
15363                 agg(k,l)=-agg(k,l)
15364                 aggi(k,l)=-aggi(k,l)
15365                 aggi1(k,l)=-aggi1(k,l)
15366                 aggj(k,l)=-aggj(k,l)
15367                 aggj1(k,l)=-aggj1(k,l)
15368               enddo
15369             enddo
15370           endif
15371           ENDIF ! WCORR
15372           IF (wel_loc.gt.0.0d0) THEN
15373 ! Contribution to the local-electrostatic energy coming from the i-j pair
15374           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15375            +a33*muij(4)
15376 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15377 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15378           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15379                   'eelloc',i,j,eel_loc_ij
15380 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15381
15382           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15383 ! Partial derivatives in virtual-bond dihedral angles gamma
15384           if (i.gt.1) &
15385           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15386                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15387                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15388                  *sss_ele_cut
15389           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15390                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15391                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15392                  *sss_ele_cut
15393            xtemp(1)=xj
15394            xtemp(2)=yj
15395            xtemp(3)=zj
15396
15397 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15398           do l=1,3
15399             ggg(l)=(agg(l,1)*muij(1)+ &
15400                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15401             *sss_ele_cut &
15402              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15403
15404             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15405             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15406 !grad            ghalf=0.5d0*ggg(l)
15407 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15408 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15409           enddo
15410 !grad          do k=i+1,j2
15411 !grad            do l=1,3
15412 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15413 !grad            enddo
15414 !grad          enddo
15415 ! Remaining derivatives of eello
15416           do l=1,3
15417             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15418                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15419             *sss_ele_cut
15420
15421             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15422                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15423             *sss_ele_cut
15424
15425             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15426                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15427             *sss_ele_cut
15428
15429             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15430                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15431             *sss_ele_cut
15432
15433           enddo
15434           ENDIF
15435 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15436 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15437           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15438              .and. num_conti.le.maxconts) then
15439 !            write (iout,*) i,j," entered corr"
15440 !
15441 ! Calculate the contact function. The ith column of the array JCONT will
15442 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15443 ! greater than I). The arrays FACONT and GACONT will contain the values of
15444 ! the contact function and its derivative.
15445 !           r0ij=1.02D0*rpp(iteli,itelj)
15446 !           r0ij=1.11D0*rpp(iteli,itelj)
15447             r0ij=2.20D0*rpp(iteli,itelj)
15448 !           r0ij=1.55D0*rpp(iteli,itelj)
15449             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15450 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15451             if (fcont.gt.0.0D0) then
15452               num_conti=num_conti+1
15453               if (num_conti.gt.maxconts) then
15454 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15455                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15456                                ' will skip next contacts for this conf.',num_conti
15457               else
15458                 jcont_hb(num_conti,i)=j
15459 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15460 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15461                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15462                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15463 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15464 !  terms.
15465                 d_cont(num_conti,i)=rij
15466 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15467 !     --- Electrostatic-interaction matrix ---
15468                 a_chuj(1,1,num_conti,i)=a22
15469                 a_chuj(1,2,num_conti,i)=a23
15470                 a_chuj(2,1,num_conti,i)=a32
15471                 a_chuj(2,2,num_conti,i)=a33
15472 !     --- Gradient of rij
15473                 do kkk=1,3
15474                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15475                 enddo
15476                 kkll=0
15477                 do k=1,2
15478                   do l=1,2
15479                     kkll=kkll+1
15480                     do m=1,3
15481                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15482                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15483                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15484                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15485                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15486                     enddo
15487                   enddo
15488                 enddo
15489                 ENDIF
15490                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15491 ! Calculate contact energies
15492                 cosa4=4.0D0*cosa
15493                 wij=cosa-3.0D0*cosb*cosg
15494                 cosbg1=cosb+cosg
15495                 cosbg2=cosb-cosg
15496 !               fac3=dsqrt(-ael6i)/r0ij**3
15497                 fac3=dsqrt(-ael6i)*r3ij
15498 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15499                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15500                 if (ees0tmp.gt.0) then
15501                   ees0pij=dsqrt(ees0tmp)
15502                 else
15503                   ees0pij=0
15504                 endif
15505 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15506                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15507                 if (ees0tmp.gt.0) then
15508                   ees0mij=dsqrt(ees0tmp)
15509                 else
15510                   ees0mij=0
15511                 endif
15512 !               ees0mij=0.0D0
15513                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15514                      *sss_ele_cut
15515
15516                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15517                      *sss_ele_cut
15518
15519 ! Diagnostics. Comment out or remove after debugging!
15520 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15521 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15522 !               ees0m(num_conti,i)=0.0D0
15523 ! End diagnostics.
15524 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15525 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15526 ! Angular derivatives of the contact function
15527                 ees0pij1=fac3/ees0pij
15528                 ees0mij1=fac3/ees0mij
15529                 fac3p=-3.0D0*fac3*rrmij
15530                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15531                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15532 !               ees0mij1=0.0D0
15533                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15534                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15535                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15536                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15537                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15538                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15539                 ecosap=ecosa1+ecosa2
15540                 ecosbp=ecosb1+ecosb2
15541                 ecosgp=ecosg1+ecosg2
15542                 ecosam=ecosa1-ecosa2
15543                 ecosbm=ecosb1-ecosb2
15544                 ecosgm=ecosg1-ecosg2
15545 ! Diagnostics
15546 !               ecosap=ecosa1
15547 !               ecosbp=ecosb1
15548 !               ecosgp=ecosg1
15549 !               ecosam=0.0D0
15550 !               ecosbm=0.0D0
15551 !               ecosgm=0.0D0
15552 ! End diagnostics
15553                 facont_hb(num_conti,i)=fcont
15554                 fprimcont=fprimcont/rij
15555 !d              facont_hb(num_conti,i)=1.0D0
15556 ! Following line is for diagnostics.
15557 !d              fprimcont=0.0D0
15558                 do k=1,3
15559                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15560                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15561                 enddo
15562                 do k=1,3
15563                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15564                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15565                 enddo
15566 !                gggp(1)=gggp(1)+ees0pijp*xj
15567 !                gggp(2)=gggp(2)+ees0pijp*yj
15568 !                gggp(3)=gggp(3)+ees0pijp*zj
15569 !                gggm(1)=gggm(1)+ees0mijp*xj
15570 !                gggm(2)=gggm(2)+ees0mijp*yj
15571 !                gggm(3)=gggm(3)+ees0mijp*zj
15572                 gggp(1)=gggp(1)+ees0pijp*xj &
15573                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15574                 gggp(2)=gggp(2)+ees0pijp*yj &
15575                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15576                 gggp(3)=gggp(3)+ees0pijp*zj &
15577                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15578
15579                 gggm(1)=gggm(1)+ees0mijp*xj &
15580                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15581
15582                 gggm(2)=gggm(2)+ees0mijp*yj &
15583                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15584
15585                 gggm(3)=gggm(3)+ees0mijp*zj &
15586                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15587
15588 ! Derivatives due to the contact function
15589                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15590                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15591                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15592                 do k=1,3
15593 !
15594 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15595 !          following the change of gradient-summation algorithm.
15596 !
15597 !grad                  ghalfp=0.5D0*gggp(k)
15598 !grad                  ghalfm=0.5D0*gggm(k)
15599 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15600 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15601 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15602 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15603 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15604 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15605 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15606 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15607 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15608 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15609 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15610 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15611 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15612 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15613                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15614                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15615                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15616                      *sss_ele_cut
15617
15618                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15619                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15620                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15621                      *sss_ele_cut
15622
15623                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15624                      *sss_ele_cut
15625
15626                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15627                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15628                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15629                      *sss_ele_cut
15630
15631                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15632                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15633                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15634                      *sss_ele_cut
15635
15636                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15637                      *sss_ele_cut
15638
15639                 enddo
15640               ENDIF ! wcorr
15641               endif  ! num_conti.le.maxconts
15642             endif  ! fcont.gt.0
15643           endif    ! j.gt.i+1
15644           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15645             do k=1,4
15646               do l=1,3
15647                 ghalf=0.5d0*agg(l,k)
15648                 aggi(l,k)=aggi(l,k)+ghalf
15649                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15650                 aggj(l,k)=aggj(l,k)+ghalf
15651               enddo
15652             enddo
15653             if (j.eq.nres-1 .and. i.lt.j-2) then
15654               do k=1,4
15655                 do l=1,3
15656                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15657                 enddo
15658               enddo
15659             endif
15660           endif
15661  128      continue
15662 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15663       return
15664       end subroutine eelecij_scale
15665 !-----------------------------------------------------------------------------
15666       subroutine evdwpp_short(evdw1)
15667 !
15668 ! Compute Evdwpp
15669 !
15670 !      implicit real*8 (a-h,o-z)
15671 !      include 'DIMENSIONS'
15672 !      include 'COMMON.CONTROL'
15673 !      include 'COMMON.IOUNITS'
15674 !      include 'COMMON.GEO'
15675 !      include 'COMMON.VAR'
15676 !      include 'COMMON.LOCAL'
15677 !      include 'COMMON.CHAIN'
15678 !      include 'COMMON.DERIV'
15679 !      include 'COMMON.INTERACT'
15680 !      include 'COMMON.CONTACTS'
15681 !      include 'COMMON.TORSION'
15682 !      include 'COMMON.VECTORS'
15683 !      include 'COMMON.FFIELD'
15684       real(kind=8),dimension(3) :: ggg
15685 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15686 #ifdef MOMENT
15687       real(kind=8) :: scal_el=1.0d0
15688 #else
15689       real(kind=8) :: scal_el=0.5d0
15690 #endif
15691 !el local variables
15692       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15693       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15694       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15695                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15696                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15697       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15698                     dist_temp, dist_init,sss_grad
15699       integer xshift,yshift,zshift
15700
15701
15702       evdw1=0.0D0
15703 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15704 !     & " iatel_e_vdw",iatel_e_vdw
15705       call flush(iout)
15706       do i=iatel_s_vdw,iatel_e_vdw
15707         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15708         dxi=dc(1,i)
15709         dyi=dc(2,i)
15710         dzi=dc(3,i)
15711         dx_normi=dc_norm(1,i)
15712         dy_normi=dc_norm(2,i)
15713         dz_normi=dc_norm(3,i)
15714         xmedi=c(1,i)+0.5d0*dxi
15715         ymedi=c(2,i)+0.5d0*dyi
15716         zmedi=c(3,i)+0.5d0*dzi
15717           xmedi=dmod(xmedi,boxxsize)
15718           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15719           ymedi=dmod(ymedi,boxysize)
15720           if (ymedi.lt.0) ymedi=ymedi+boxysize
15721           zmedi=dmod(zmedi,boxzsize)
15722           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15723         num_conti=0
15724 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15725 !     &   ' ielend',ielend_vdw(i)
15726         call flush(iout)
15727         do j=ielstart_vdw(i),ielend_vdw(i)
15728           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15729 !el          ind=ind+1
15730           iteli=itel(i)
15731           itelj=itel(j)
15732           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15733           aaa=app(iteli,itelj)
15734           bbb=bpp(iteli,itelj)
15735           dxj=dc(1,j)
15736           dyj=dc(2,j)
15737           dzj=dc(3,j)
15738           dx_normj=dc_norm(1,j)
15739           dy_normj=dc_norm(2,j)
15740           dz_normj=dc_norm(3,j)
15741 !          xj=c(1,j)+0.5D0*dxj-xmedi
15742 !          yj=c(2,j)+0.5D0*dyj-ymedi
15743 !          zj=c(3,j)+0.5D0*dzj-zmedi
15744           xj=c(1,j)+0.5D0*dxj
15745           yj=c(2,j)+0.5D0*dyj
15746           zj=c(3,j)+0.5D0*dzj
15747           xj=mod(xj,boxxsize)
15748           if (xj.lt.0) xj=xj+boxxsize
15749           yj=mod(yj,boxysize)
15750           if (yj.lt.0) yj=yj+boxysize
15751           zj=mod(zj,boxzsize)
15752           if (zj.lt.0) zj=zj+boxzsize
15753       isubchap=0
15754       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15755       xj_safe=xj
15756       yj_safe=yj
15757       zj_safe=zj
15758       do xshift=-1,1
15759       do yshift=-1,1
15760       do zshift=-1,1
15761           xj=xj_safe+xshift*boxxsize
15762           yj=yj_safe+yshift*boxysize
15763           zj=zj_safe+zshift*boxzsize
15764           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15765           if(dist_temp.lt.dist_init) then
15766             dist_init=dist_temp
15767             xj_temp=xj
15768             yj_temp=yj
15769             zj_temp=zj
15770             isubchap=1
15771           endif
15772        enddo
15773        enddo
15774        enddo
15775        if (isubchap.eq.1) then
15776 !C          print *,i,j
15777           xj=xj_temp-xmedi
15778           yj=yj_temp-ymedi
15779           zj=zj_temp-zmedi
15780        else
15781           xj=xj_safe-xmedi
15782           yj=yj_safe-ymedi
15783           zj=zj_safe-zmedi
15784        endif
15785
15786           rij=xj*xj+yj*yj+zj*zj
15787           rrmij=1.0D0/rij
15788           rij=dsqrt(rij)
15789           sss=sscale(rij/rpp(iteli,itelj))
15790             sss_ele_cut=sscale_ele(rij)
15791             sss_ele_grad=sscagrad_ele(rij)
15792             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15793             if (sss_ele_cut.le.0.0) cycle
15794           if (sss.gt.0.0d0) then
15795             rmij=1.0D0/rij
15796             r3ij=rrmij*rmij
15797             r6ij=r3ij*r3ij
15798             ev1=aaa*r6ij*r6ij
15799 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15800             if (j.eq.i+2) ev1=scal_el*ev1
15801             ev2=bbb*r6ij
15802             evdwij=ev1+ev2
15803             if (energy_dec) then
15804               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15805             endif
15806             evdw1=evdw1+evdwij*sss*sss_ele_cut
15807 !
15808 ! Calculate contributions to the Cartesian gradient.
15809 !
15810             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15811 !            ggg(1)=facvdw*xj
15812 !            ggg(2)=facvdw*yj
15813 !            ggg(3)=facvdw*zj
15814           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15815           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15816           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15817           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15818           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15819           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15820
15821             do k=1,3
15822               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15823               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15824             enddo
15825           endif
15826         enddo ! j
15827       enddo   ! i
15828       return
15829       end subroutine evdwpp_short
15830 !-----------------------------------------------------------------------------
15831       subroutine escp_long(evdw2,evdw2_14)
15832 !
15833 ! This subroutine calculates the excluded-volume interaction energy between
15834 ! peptide-group centers and side chains and its gradient in virtual-bond and
15835 ! side-chain vectors.
15836 !
15837 !      implicit real*8 (a-h,o-z)
15838 !      include 'DIMENSIONS'
15839 !      include 'COMMON.GEO'
15840 !      include 'COMMON.VAR'
15841 !      include 'COMMON.LOCAL'
15842 !      include 'COMMON.CHAIN'
15843 !      include 'COMMON.DERIV'
15844 !      include 'COMMON.INTERACT'
15845 !      include 'COMMON.FFIELD'
15846 !      include 'COMMON.IOUNITS'
15847 !      include 'COMMON.CONTROL'
15848       real(kind=8),dimension(3) :: ggg
15849 !el local variables
15850       integer :: i,iint,j,k,iteli,itypj,subchap
15851       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15852       real(kind=8) :: evdw2,evdw2_14,evdwij
15853       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15854                     dist_temp, dist_init
15855
15856       evdw2=0.0D0
15857       evdw2_14=0.0d0
15858 !d    print '(a)','Enter ESCP'
15859 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15860       do i=iatscp_s,iatscp_e
15861         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15862         iteli=itel(i)
15863         xi=0.5D0*(c(1,i)+c(1,i+1))
15864         yi=0.5D0*(c(2,i)+c(2,i+1))
15865         zi=0.5D0*(c(3,i)+c(3,i+1))
15866           xi=mod(xi,boxxsize)
15867           if (xi.lt.0) xi=xi+boxxsize
15868           yi=mod(yi,boxysize)
15869           if (yi.lt.0) yi=yi+boxysize
15870           zi=mod(zi,boxzsize)
15871           if (zi.lt.0) zi=zi+boxzsize
15872
15873         do iint=1,nscp_gr(i)
15874
15875         do j=iscpstart(i,iint),iscpend(i,iint)
15876           itypj=itype(j,1)
15877           if (itypj.eq.ntyp1) cycle
15878 ! Uncomment following three lines for SC-p interactions
15879 !         xj=c(1,nres+j)-xi
15880 !         yj=c(2,nres+j)-yi
15881 !         zj=c(3,nres+j)-zi
15882 ! Uncomment following three lines for Ca-p interactions
15883           xj=c(1,j)
15884           yj=c(2,j)
15885           zj=c(3,j)
15886           xj=mod(xj,boxxsize)
15887           if (xj.lt.0) xj=xj+boxxsize
15888           yj=mod(yj,boxysize)
15889           if (yj.lt.0) yj=yj+boxysize
15890           zj=mod(zj,boxzsize)
15891           if (zj.lt.0) zj=zj+boxzsize
15892       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15893       xj_safe=xj
15894       yj_safe=yj
15895       zj_safe=zj
15896       subchap=0
15897       do xshift=-1,1
15898       do yshift=-1,1
15899       do zshift=-1,1
15900           xj=xj_safe+xshift*boxxsize
15901           yj=yj_safe+yshift*boxysize
15902           zj=zj_safe+zshift*boxzsize
15903           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15904           if(dist_temp.lt.dist_init) then
15905             dist_init=dist_temp
15906             xj_temp=xj
15907             yj_temp=yj
15908             zj_temp=zj
15909             subchap=1
15910           endif
15911        enddo
15912        enddo
15913        enddo
15914        if (subchap.eq.1) then
15915           xj=xj_temp-xi
15916           yj=yj_temp-yi
15917           zj=zj_temp-zi
15918        else
15919           xj=xj_safe-xi
15920           yj=yj_safe-yi
15921           zj=zj_safe-zi
15922        endif
15923           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15924
15925           rij=dsqrt(1.0d0/rrij)
15926             sss_ele_cut=sscale_ele(rij)
15927             sss_ele_grad=sscagrad_ele(rij)
15928 !            print *,sss_ele_cut,sss_ele_grad,&
15929 !            (rij),r_cut_ele,rlamb_ele
15930             if (sss_ele_cut.le.0.0) cycle
15931           sss=sscale((rij/rscp(itypj,iteli)))
15932           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15933           if (sss.lt.1.0d0) then
15934
15935             fac=rrij**expon2
15936             e1=fac*fac*aad(itypj,iteli)
15937             e2=fac*bad(itypj,iteli)
15938             if (iabs(j-i) .le. 2) then
15939               e1=scal14*e1
15940               e2=scal14*e2
15941               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15942             endif
15943             evdwij=e1+e2
15944             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15945             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15946                 'evdw2',i,j,sss,evdwij
15947 !
15948 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15949 !
15950             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15951             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15952             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15953             ggg(1)=xj*fac
15954             ggg(2)=yj*fac
15955             ggg(3)=zj*fac
15956 ! Uncomment following three lines for SC-p interactions
15957 !           do k=1,3
15958 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15959 !           enddo
15960 ! Uncomment following line for SC-p interactions
15961 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15962             do k=1,3
15963               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15964               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15965             enddo
15966           endif
15967         enddo
15968
15969         enddo ! iint
15970       enddo ! i
15971       do i=1,nct
15972         do j=1,3
15973           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15974           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15975           gradx_scp(j,i)=expon*gradx_scp(j,i)
15976         enddo
15977       enddo
15978 !******************************************************************************
15979 !
15980 !                              N O T E !!!
15981 !
15982 ! To save time the factor EXPON has been extracted from ALL components
15983 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15984 ! use!
15985 !
15986 !******************************************************************************
15987       return
15988       end subroutine escp_long
15989 !-----------------------------------------------------------------------------
15990       subroutine escp_short(evdw2,evdw2_14)
15991 !
15992 ! This subroutine calculates the excluded-volume interaction energy between
15993 ! peptide-group centers and side chains and its gradient in virtual-bond and
15994 ! side-chain vectors.
15995 !
15996 !      implicit real*8 (a-h,o-z)
15997 !      include 'DIMENSIONS'
15998 !      include 'COMMON.GEO'
15999 !      include 'COMMON.VAR'
16000 !      include 'COMMON.LOCAL'
16001 !      include 'COMMON.CHAIN'
16002 !      include 'COMMON.DERIV'
16003 !      include 'COMMON.INTERACT'
16004 !      include 'COMMON.FFIELD'
16005 !      include 'COMMON.IOUNITS'
16006 !      include 'COMMON.CONTROL'
16007       real(kind=8),dimension(3) :: ggg
16008 !el local variables
16009       integer :: i,iint,j,k,iteli,itypj,subchap
16010       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16011       real(kind=8) :: evdw2,evdw2_14,evdwij
16012       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16013                     dist_temp, dist_init
16014
16015       evdw2=0.0D0
16016       evdw2_14=0.0d0
16017 !d    print '(a)','Enter ESCP'
16018 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16019       do i=iatscp_s,iatscp_e
16020         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16021         iteli=itel(i)
16022         xi=0.5D0*(c(1,i)+c(1,i+1))
16023         yi=0.5D0*(c(2,i)+c(2,i+1))
16024         zi=0.5D0*(c(3,i)+c(3,i+1))
16025           xi=mod(xi,boxxsize)
16026           if (xi.lt.0) xi=xi+boxxsize
16027           yi=mod(yi,boxysize)
16028           if (yi.lt.0) yi=yi+boxysize
16029           zi=mod(zi,boxzsize)
16030           if (zi.lt.0) zi=zi+boxzsize
16031
16032         do iint=1,nscp_gr(i)
16033
16034         do j=iscpstart(i,iint),iscpend(i,iint)
16035           itypj=itype(j,1)
16036           if (itypj.eq.ntyp1) cycle
16037 ! Uncomment following three lines for SC-p interactions
16038 !         xj=c(1,nres+j)-xi
16039 !         yj=c(2,nres+j)-yi
16040 !         zj=c(3,nres+j)-zi
16041 ! Uncomment following three lines for Ca-p interactions
16042 !          xj=c(1,j)-xi
16043 !          yj=c(2,j)-yi
16044 !          zj=c(3,j)-zi
16045           xj=c(1,j)
16046           yj=c(2,j)
16047           zj=c(3,j)
16048           xj=mod(xj,boxxsize)
16049           if (xj.lt.0) xj=xj+boxxsize
16050           yj=mod(yj,boxysize)
16051           if (yj.lt.0) yj=yj+boxysize
16052           zj=mod(zj,boxzsize)
16053           if (zj.lt.0) zj=zj+boxzsize
16054       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16055       xj_safe=xj
16056       yj_safe=yj
16057       zj_safe=zj
16058       subchap=0
16059       do xshift=-1,1
16060       do yshift=-1,1
16061       do zshift=-1,1
16062           xj=xj_safe+xshift*boxxsize
16063           yj=yj_safe+yshift*boxysize
16064           zj=zj_safe+zshift*boxzsize
16065           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16066           if(dist_temp.lt.dist_init) then
16067             dist_init=dist_temp
16068             xj_temp=xj
16069             yj_temp=yj
16070             zj_temp=zj
16071             subchap=1
16072           endif
16073        enddo
16074        enddo
16075        enddo
16076        if (subchap.eq.1) then
16077           xj=xj_temp-xi
16078           yj=yj_temp-yi
16079           zj=zj_temp-zi
16080        else
16081           xj=xj_safe-xi
16082           yj=yj_safe-yi
16083           zj=zj_safe-zi
16084        endif
16085
16086           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16087           rij=dsqrt(1.0d0/rrij)
16088             sss_ele_cut=sscale_ele(rij)
16089             sss_ele_grad=sscagrad_ele(rij)
16090 !            print *,sss_ele_cut,sss_ele_grad,&
16091 !            (rij),r_cut_ele,rlamb_ele
16092             if (sss_ele_cut.le.0.0) cycle
16093           sss=sscale(rij/rscp(itypj,iteli))
16094           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16095           if (sss.gt.0.0d0) then
16096
16097             fac=rrij**expon2
16098             e1=fac*fac*aad(itypj,iteli)
16099             e2=fac*bad(itypj,iteli)
16100             if (iabs(j-i) .le. 2) then
16101               e1=scal14*e1
16102               e2=scal14*e2
16103               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16104             endif
16105             evdwij=e1+e2
16106             evdw2=evdw2+evdwij*sss*sss_ele_cut
16107             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16108                 'evdw2',i,j,sss,evdwij
16109 !
16110 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16111 !
16112             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16113             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16114             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16115
16116             ggg(1)=xj*fac
16117             ggg(2)=yj*fac
16118             ggg(3)=zj*fac
16119 ! Uncomment following three lines for SC-p interactions
16120 !           do k=1,3
16121 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16122 !           enddo
16123 ! Uncomment following line for SC-p interactions
16124 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16125             do k=1,3
16126               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16127               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16128             enddo
16129           endif
16130         enddo
16131
16132         enddo ! iint
16133       enddo ! i
16134       do i=1,nct
16135         do j=1,3
16136           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16137           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16138           gradx_scp(j,i)=expon*gradx_scp(j,i)
16139         enddo
16140       enddo
16141 !******************************************************************************
16142 !
16143 !                              N O T E !!!
16144 !
16145 ! To save time the factor EXPON has been extracted from ALL components
16146 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16147 ! use!
16148 !
16149 !******************************************************************************
16150       return
16151       end subroutine escp_short
16152 !-----------------------------------------------------------------------------
16153 ! energy_p_new-sep_barrier.F
16154 !-----------------------------------------------------------------------------
16155       subroutine sc_grad_scale(scalfac)
16156 !      implicit real*8 (a-h,o-z)
16157       use calc_data
16158 !      include 'DIMENSIONS'
16159 !      include 'COMMON.CHAIN'
16160 !      include 'COMMON.DERIV'
16161 !      include 'COMMON.CALC'
16162 !      include 'COMMON.IOUNITS'
16163       real(kind=8),dimension(3) :: dcosom1,dcosom2
16164       real(kind=8) :: scalfac
16165 !el local variables
16166 !      integer :: i,j,k,l
16167
16168       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16169       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16170       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16171            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16172 ! diagnostics only
16173 !      eom1=0.0d0
16174 !      eom2=0.0d0
16175 !      eom12=evdwij*eps1_om12
16176 ! end diagnostics
16177 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16178 !     &  " sigder",sigder
16179 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16180 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16181       do k=1,3
16182         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16183         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16184       enddo
16185       do k=1,3
16186         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16187          *sss_ele_cut
16188       enddo
16189 !      write (iout,*) "gg",(gg(k),k=1,3)
16190       do k=1,3
16191         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16192                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16193                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16194                  *sss_ele_cut
16195         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16196                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16197                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16198          *sss_ele_cut
16199 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16200 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16201 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16202 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16203       enddo
16204 !
16205 ! Calculate the components of the gradient in DC and X
16206 !
16207       do l=1,3
16208         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16209         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16210       enddo
16211       return
16212       end subroutine sc_grad_scale
16213 !-----------------------------------------------------------------------------
16214 ! energy_split-sep.F
16215 !-----------------------------------------------------------------------------
16216       subroutine etotal_long(energia)
16217 !
16218 ! Compute the long-range slow-varying contributions to the energy
16219 !
16220 !      implicit real*8 (a-h,o-z)
16221 !      include 'DIMENSIONS'
16222       use MD_data, only: totT,usampl,eq_time
16223 #ifndef ISNAN
16224       external proc_proc
16225 #ifdef WINPGI
16226 !MS$ATTRIBUTES C ::  proc_proc
16227 #endif
16228 #endif
16229 #ifdef MPI
16230       include "mpif.h"
16231       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16232 #endif
16233 !      include 'COMMON.SETUP'
16234 !      include 'COMMON.IOUNITS'
16235 !      include 'COMMON.FFIELD'
16236 !      include 'COMMON.DERIV'
16237 !      include 'COMMON.INTERACT'
16238 !      include 'COMMON.SBRIDGE'
16239 !      include 'COMMON.CHAIN'
16240 !      include 'COMMON.VAR'
16241 !      include 'COMMON.LOCAL'
16242 !      include 'COMMON.MD'
16243       real(kind=8),dimension(0:n_ene) :: energia
16244 !el local variables
16245       integer :: i,n_corr,n_corr1,ierror,ierr
16246       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16247                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16248                   ecorr,ecorr5,ecorr6,eturn6,time00
16249 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16250 !elwrite(iout,*)"in etotal long"
16251
16252       if (modecalc.eq.12.or.modecalc.eq.14) then
16253 #ifdef MPI
16254 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16255 #else
16256         call int_from_cart1(.false.)
16257 #endif
16258       endif
16259 !elwrite(iout,*)"in etotal long"
16260
16261 #ifdef MPI
16262 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16263 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16264       call flush(iout)
16265       if (nfgtasks.gt.1) then
16266         time00=MPI_Wtime()
16267 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16268         if (fg_rank.eq.0) then
16269           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16270 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16271 !          call flush(iout)
16272 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16273 ! FG slaves as WEIGHTS array.
16274           weights_(1)=wsc
16275           weights_(2)=wscp
16276           weights_(3)=welec
16277           weights_(4)=wcorr
16278           weights_(5)=wcorr5
16279           weights_(6)=wcorr6
16280           weights_(7)=wel_loc
16281           weights_(8)=wturn3
16282           weights_(9)=wturn4
16283           weights_(10)=wturn6
16284           weights_(11)=wang
16285           weights_(12)=wscloc
16286           weights_(13)=wtor
16287           weights_(14)=wtor_d
16288           weights_(15)=wstrain
16289           weights_(16)=wvdwpp
16290           weights_(17)=wbond
16291           weights_(18)=scal14
16292           weights_(21)=wsccor
16293 ! FG Master broadcasts the WEIGHTS_ array
16294           call MPI_Bcast(weights_(1),n_ene,&
16295               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16296         else
16297 ! FG slaves receive the WEIGHTS array
16298           call MPI_Bcast(weights(1),n_ene,&
16299               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16300           wsc=weights(1)
16301           wscp=weights(2)
16302           welec=weights(3)
16303           wcorr=weights(4)
16304           wcorr5=weights(5)
16305           wcorr6=weights(6)
16306           wel_loc=weights(7)
16307           wturn3=weights(8)
16308           wturn4=weights(9)
16309           wturn6=weights(10)
16310           wang=weights(11)
16311           wscloc=weights(12)
16312           wtor=weights(13)
16313           wtor_d=weights(14)
16314           wstrain=weights(15)
16315           wvdwpp=weights(16)
16316           wbond=weights(17)
16317           scal14=weights(18)
16318           wsccor=weights(21)
16319         endif
16320         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16321           king,FG_COMM,IERR)
16322          time_Bcast=time_Bcast+MPI_Wtime()-time00
16323          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16324 !        call chainbuild_cart
16325 !        call int_from_cart1(.false.)
16326       endif
16327 !      write (iout,*) 'Processor',myrank,
16328 !     &  ' calling etotal_short ipot=',ipot
16329 !      call flush(iout)
16330 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16331 #endif
16332 !d    print *,'nnt=',nnt,' nct=',nct
16333 !
16334 !elwrite(iout,*)"in etotal long"
16335 ! Compute the side-chain and electrostatic interaction energy
16336 !
16337       goto (101,102,103,104,105,106) ipot
16338 ! Lennard-Jones potential.
16339   101 call elj_long(evdw)
16340 !d    print '(a)','Exit ELJ'
16341       goto 107
16342 ! Lennard-Jones-Kihara potential (shifted).
16343   102 call eljk_long(evdw)
16344       goto 107
16345 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16346   103 call ebp_long(evdw)
16347       goto 107
16348 ! Gay-Berne potential (shifted LJ, angular dependence).
16349   104 call egb_long(evdw)
16350       goto 107
16351 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16352   105 call egbv_long(evdw)
16353       goto 107
16354 ! Soft-sphere potential
16355   106 call e_softsphere(evdw)
16356 !
16357 ! Calculate electrostatic (H-bonding) energy of the main chain.
16358 !
16359   107 continue
16360       call vec_and_deriv
16361       if (ipot.lt.6) then
16362 #ifdef SPLITELE
16363          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16364              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16365              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16366              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16367 #else
16368          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16369              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16370              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16371              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16372 #endif
16373            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16374          else
16375             ees=0
16376             evdw1=0
16377             eel_loc=0
16378             eello_turn3=0
16379             eello_turn4=0
16380          endif
16381       else
16382 !        write (iout,*) "Soft-spheer ELEC potential"
16383         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16384          eello_turn4)
16385       endif
16386 !
16387 ! Calculate excluded-volume interaction energy between peptide groups
16388 ! and side chains.
16389 !
16390       if (ipot.lt.6) then
16391        if(wscp.gt.0d0) then
16392         call escp_long(evdw2,evdw2_14)
16393        else
16394         evdw2=0
16395         evdw2_14=0
16396        endif
16397       else
16398         call escp_soft_sphere(evdw2,evdw2_14)
16399       endif
16400 !
16401 ! 12/1/95 Multi-body terms
16402 !
16403       n_corr=0
16404       n_corr1=0
16405       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16406           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16407          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16408 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16409 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16410       else
16411          ecorr=0.0d0
16412          ecorr5=0.0d0
16413          ecorr6=0.0d0
16414          eturn6=0.0d0
16415       endif
16416       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16417          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16418       endif
16419 !
16420 ! If performing constraint dynamics, call the constraint energy
16421 !  after the equilibration time
16422       if(usampl.and.totT.gt.eq_time) then
16423          call EconstrQ
16424          call Econstr_back
16425       else
16426          Uconst=0.0d0
16427          Uconst_back=0.0d0
16428       endif
16429 !
16430 ! Sum the energies
16431 !
16432       do i=1,n_ene
16433         energia(i)=0.0d0
16434       enddo
16435       energia(1)=evdw
16436 #ifdef SCP14
16437       energia(2)=evdw2-evdw2_14
16438       energia(18)=evdw2_14
16439 #else
16440       energia(2)=evdw2
16441       energia(18)=0.0d0
16442 #endif
16443 #ifdef SPLITELE
16444       energia(3)=ees
16445       energia(16)=evdw1
16446 #else
16447       energia(3)=ees+evdw1
16448       energia(16)=0.0d0
16449 #endif
16450       energia(4)=ecorr
16451       energia(5)=ecorr5
16452       energia(6)=ecorr6
16453       energia(7)=eel_loc
16454       energia(8)=eello_turn3
16455       energia(9)=eello_turn4
16456       energia(10)=eturn6
16457       energia(20)=Uconst+Uconst_back
16458       call sum_energy(energia,.true.)
16459 !      write (iout,*) "Exit ETOTAL_LONG"
16460       call flush(iout)
16461       return
16462       end subroutine etotal_long
16463 !-----------------------------------------------------------------------------
16464       subroutine etotal_short(energia)
16465 !
16466 ! Compute the short-range fast-varying contributions to the energy
16467 !
16468 !      implicit real*8 (a-h,o-z)
16469 !      include 'DIMENSIONS'
16470 #ifndef ISNAN
16471       external proc_proc
16472 #ifdef WINPGI
16473 !MS$ATTRIBUTES C ::  proc_proc
16474 #endif
16475 #endif
16476 #ifdef MPI
16477       include "mpif.h"
16478       integer :: ierror,ierr
16479       real(kind=8),dimension(n_ene) :: weights_
16480       real(kind=8) :: time00
16481 #endif
16482 !      include 'COMMON.SETUP'
16483 !      include 'COMMON.IOUNITS'
16484 !      include 'COMMON.FFIELD'
16485 !      include 'COMMON.DERIV'
16486 !      include 'COMMON.INTERACT'
16487 !      include 'COMMON.SBRIDGE'
16488 !      include 'COMMON.CHAIN'
16489 !      include 'COMMON.VAR'
16490 !      include 'COMMON.LOCAL'
16491       real(kind=8),dimension(0:n_ene) :: energia
16492 !el local variables
16493       integer :: i,nres6
16494       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16495       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16496       nres6=6*nres
16497
16498 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16499 !      call flush(iout)
16500       if (modecalc.eq.12.or.modecalc.eq.14) then
16501 #ifdef MPI
16502         if (fg_rank.eq.0) call int_from_cart1(.false.)
16503 #else
16504         call int_from_cart1(.false.)
16505 #endif
16506       endif
16507 #ifdef MPI
16508 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16509 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16510 !      call flush(iout)
16511       if (nfgtasks.gt.1) then
16512         time00=MPI_Wtime()
16513 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16514         if (fg_rank.eq.0) then
16515           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16516 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16517 !          call flush(iout)
16518 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16519 ! FG slaves as WEIGHTS array.
16520           weights_(1)=wsc
16521           weights_(2)=wscp
16522           weights_(3)=welec
16523           weights_(4)=wcorr
16524           weights_(5)=wcorr5
16525           weights_(6)=wcorr6
16526           weights_(7)=wel_loc
16527           weights_(8)=wturn3
16528           weights_(9)=wturn4
16529           weights_(10)=wturn6
16530           weights_(11)=wang
16531           weights_(12)=wscloc
16532           weights_(13)=wtor
16533           weights_(14)=wtor_d
16534           weights_(15)=wstrain
16535           weights_(16)=wvdwpp
16536           weights_(17)=wbond
16537           weights_(18)=scal14
16538           weights_(21)=wsccor
16539 ! FG Master broadcasts the WEIGHTS_ array
16540           call MPI_Bcast(weights_(1),n_ene,&
16541               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16542         else
16543 ! FG slaves receive the WEIGHTS array
16544           call MPI_Bcast(weights(1),n_ene,&
16545               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16546           wsc=weights(1)
16547           wscp=weights(2)
16548           welec=weights(3)
16549           wcorr=weights(4)
16550           wcorr5=weights(5)
16551           wcorr6=weights(6)
16552           wel_loc=weights(7)
16553           wturn3=weights(8)
16554           wturn4=weights(9)
16555           wturn6=weights(10)
16556           wang=weights(11)
16557           wscloc=weights(12)
16558           wtor=weights(13)
16559           wtor_d=weights(14)
16560           wstrain=weights(15)
16561           wvdwpp=weights(16)
16562           wbond=weights(17)
16563           scal14=weights(18)
16564           wsccor=weights(21)
16565         endif
16566 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16567         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16568           king,FG_COMM,IERR)
16569 !        write (iout,*) "Processor",myrank," BROADCAST c"
16570         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16571           king,FG_COMM,IERR)
16572 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16573         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16574           king,FG_COMM,IERR)
16575 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16576         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16577           king,FG_COMM,IERR)
16578 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16579         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16580           king,FG_COMM,IERR)
16581 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16582         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16583           king,FG_COMM,IERR)
16584 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16585         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16586           king,FG_COMM,IERR)
16587 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16588         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16589           king,FG_COMM,IERR)
16590 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16591         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16592           king,FG_COMM,IERR)
16593          time_Bcast=time_Bcast+MPI_Wtime()-time00
16594 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16595       endif
16596 !      write (iout,*) 'Processor',myrank,
16597 !     &  ' calling etotal_short ipot=',ipot
16598 !      call flush(iout)
16599 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16600 #endif
16601 !      call int_from_cart1(.false.)
16602 !
16603 ! Compute the side-chain and electrostatic interaction energy
16604 !
16605       goto (101,102,103,104,105,106) ipot
16606 ! Lennard-Jones potential.
16607   101 call elj_short(evdw)
16608 !d    print '(a)','Exit ELJ'
16609       goto 107
16610 ! Lennard-Jones-Kihara potential (shifted).
16611   102 call eljk_short(evdw)
16612       goto 107
16613 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16614   103 call ebp_short(evdw)
16615       goto 107
16616 ! Gay-Berne potential (shifted LJ, angular dependence).
16617   104 call egb_short(evdw)
16618       goto 107
16619 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16620   105 call egbv_short(evdw)
16621       goto 107
16622 ! Soft-sphere potential - already dealt with in the long-range part
16623   106 evdw=0.0d0
16624 !  106 call e_softsphere_short(evdw)
16625 !
16626 ! Calculate electrostatic (H-bonding) energy of the main chain.
16627 !
16628   107 continue
16629 !
16630 ! Calculate the short-range part of Evdwpp
16631 !
16632       call evdwpp_short(evdw1)
16633 !
16634 ! Calculate the short-range part of ESCp
16635 !
16636       if (ipot.lt.6) then
16637         call escp_short(evdw2,evdw2_14)
16638       endif
16639 !
16640 ! Calculate the bond-stretching energy
16641 !
16642       call ebond(estr)
16643 !
16644 ! Calculate the disulfide-bridge and other energy and the contributions
16645 ! from other distance constraints.
16646       call edis(ehpb)
16647 !
16648 ! Calculate the virtual-bond-angle energy.
16649 !
16650 ! Calculate the SC local energy.
16651 !
16652       call vec_and_deriv
16653       call esc(escloc)
16654 !
16655       if (wang.gt.0d0) then
16656        if (tor_mode.eq.0) then
16657          call ebend(ebe)
16658        else
16659 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16660 !C energy function
16661          call ebend_kcc(ebe)
16662        endif
16663       else
16664         ebe=0.0d0
16665       endif
16666       ethetacnstr=0.0d0
16667       if (with_theta_constr) call etheta_constr(ethetacnstr)
16668
16669 !       write(iout,*) "in etotal afer ebe",ipot
16670
16671 !      print *,"Processor",myrank," computed UB"
16672 !
16673 ! Calculate the SC local energy.
16674 !
16675       call esc(escloc)
16676 !elwrite(iout,*) "in etotal afer esc",ipot
16677 !      print *,"Processor",myrank," computed USC"
16678 !
16679 ! Calculate the virtual-bond torsional energy.
16680 !
16681 !d    print *,'nterm=',nterm
16682 !      if (wtor.gt.0) then
16683 !       call etor(etors,edihcnstr)
16684 !      else
16685 !       etors=0
16686 !       edihcnstr=0
16687 !      endif
16688       if (wtor.gt.0.0d0) then
16689          if (tor_mode.eq.0) then
16690            call etor(etors)
16691          else
16692 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16693 !C energy function
16694            call etor_kcc(etors)
16695          endif
16696       else
16697         etors=0.0d0
16698       endif
16699       edihcnstr=0.0d0
16700       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16701
16702 ! Calculate the virtual-bond torsional energy.
16703 !
16704 !
16705 ! 6/23/01 Calculate double-torsional energy
16706 !
16707       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16708       call etor_d(etors_d)
16709       endif
16710 !
16711 ! 21/5/07 Calculate local sicdechain correlation energy
16712 !
16713       if (wsccor.gt.0.0d0) then
16714         call eback_sc_corr(esccor)
16715       else
16716         esccor=0.0d0
16717       endif
16718 !
16719 ! Put energy components into an array
16720 !
16721       do i=1,n_ene
16722         energia(i)=0.0d0
16723       enddo
16724       energia(1)=evdw
16725 #ifdef SCP14
16726       energia(2)=evdw2-evdw2_14
16727       energia(18)=evdw2_14
16728 #else
16729       energia(2)=evdw2
16730       energia(18)=0.0d0
16731 #endif
16732 #ifdef SPLITELE
16733       energia(16)=evdw1
16734 #else
16735       energia(3)=evdw1
16736 #endif
16737       energia(11)=ebe
16738       energia(12)=escloc
16739       energia(13)=etors
16740       energia(14)=etors_d
16741       energia(15)=ehpb
16742       energia(17)=estr
16743       energia(19)=edihcnstr
16744       energia(21)=esccor
16745 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16746       call flush(iout)
16747       call sum_energy(energia,.true.)
16748 !      write (iout,*) "Exit ETOTAL_SHORT"
16749       call flush(iout)
16750       return
16751       end subroutine etotal_short
16752 !-----------------------------------------------------------------------------
16753 ! gnmr1.f
16754 !-----------------------------------------------------------------------------
16755       real(kind=8) function gnmr1(y,ymin,ymax)
16756 !      implicit none
16757       real(kind=8) :: y,ymin,ymax
16758       real(kind=8) :: wykl=4.0d0
16759       if (y.lt.ymin) then
16760         gnmr1=(ymin-y)**wykl/wykl
16761       else if (y.gt.ymax) then
16762         gnmr1=(y-ymax)**wykl/wykl
16763       else
16764         gnmr1=0.0d0
16765       endif
16766       return
16767       end function gnmr1
16768 !-----------------------------------------------------------------------------
16769       real(kind=8) function gnmr1prim(y,ymin,ymax)
16770 !      implicit none
16771       real(kind=8) :: y,ymin,ymax
16772       real(kind=8) :: wykl=4.0d0
16773       if (y.lt.ymin) then
16774         gnmr1prim=-(ymin-y)**(wykl-1)
16775       else if (y.gt.ymax) then
16776         gnmr1prim=(y-ymax)**(wykl-1)
16777       else
16778         gnmr1prim=0.0d0
16779       endif
16780       return
16781       end function gnmr1prim
16782 !----------------------------------------------------------------------------
16783       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16784       real(kind=8) y,ymin,ymax,sigma
16785       real(kind=8) wykl /4.0d0/
16786       if (y.lt.ymin) then
16787         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16788       else if (y.gt.ymax) then
16789         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16790       else
16791         rlornmr1=0.0d0
16792       endif
16793       return
16794       end function rlornmr1
16795 !------------------------------------------------------------------------------
16796       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16797       real(kind=8) y,ymin,ymax,sigma
16798       real(kind=8) wykl /4.0d0/
16799       if (y.lt.ymin) then
16800         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16801         ((ymin-y)**wykl+sigma**wykl)**2
16802       else if (y.gt.ymax) then
16803         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16804         ((y-ymax)**wykl+sigma**wykl)**2
16805       else
16806         rlornmr1prim=0.0d0
16807       endif
16808       return
16809       end function rlornmr1prim
16810
16811       real(kind=8) function harmonic(y,ymax)
16812 !      implicit none
16813       real(kind=8) :: y,ymax
16814       real(kind=8) :: wykl=2.0d0
16815       harmonic=(y-ymax)**wykl
16816       return
16817       end function harmonic
16818 !-----------------------------------------------------------------------------
16819       real(kind=8) function harmonicprim(y,ymax)
16820       real(kind=8) :: y,ymin,ymax
16821       real(kind=8) :: wykl=2.0d0
16822       harmonicprim=(y-ymax)*wykl
16823       return
16824       end function harmonicprim
16825 !-----------------------------------------------------------------------------
16826 ! gradient_p.F
16827 !-----------------------------------------------------------------------------
16828       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16829
16830       use io_base, only:intout,briefout
16831 !      implicit real*8 (a-h,o-z)
16832 !      include 'DIMENSIONS'
16833 !      include 'COMMON.CHAIN'
16834 !      include 'COMMON.DERIV'
16835 !      include 'COMMON.VAR'
16836 !      include 'COMMON.INTERACT'
16837 !      include 'COMMON.FFIELD'
16838 !      include 'COMMON.MD'
16839 !      include 'COMMON.IOUNITS'
16840       real(kind=8),external :: ufparm
16841       integer :: uiparm(1)
16842       real(kind=8) :: urparm(1)
16843       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16844       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16845       integer :: n,nf,ind,ind1,i,k,j
16846 !
16847 ! This subroutine calculates total internal coordinate gradient.
16848 ! Depending on the number of function evaluations, either whole energy
16849 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16850 ! internal coordinates are reevaluated or only the cartesian-in-internal
16851 ! coordinate derivatives are evaluated. The subroutine was designed to work
16852 ! with SUMSL.
16853 !
16854 !
16855       icg=mod(nf,2)+1
16856
16857 !d      print *,'grad',nf,icg
16858       if (nf-nfl+1) 20,30,40
16859    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16860 !    write (iout,*) 'grad 20'
16861       if (nf.eq.0) return
16862       goto 40
16863    30 call var_to_geom(n,x)
16864       call chainbuild
16865 !    write (iout,*) 'grad 30'
16866 !
16867 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16868 !
16869    40 call cartder
16870 !     write (iout,*) 'grad 40'
16871 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16872 !
16873 ! Convert the Cartesian gradient into internal-coordinate gradient.
16874 !
16875       ind=0
16876       ind1=0
16877       do i=1,nres-2
16878       gthetai=0.0D0
16879       gphii=0.0D0
16880       do j=i+1,nres-1
16881           ind=ind+1
16882 !         ind=indmat(i,j)
16883 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16884         do k=1,3
16885             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16886           enddo
16887         do k=1,3
16888           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16889           enddo
16890         enddo
16891       do j=i+1,nres-1
16892           ind1=ind1+1
16893 !         ind1=indmat(i,j)
16894 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16895         do k=1,3
16896           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16897           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16898           enddo
16899         enddo
16900       if (i.gt.1) g(i-1)=gphii
16901       if (n.gt.nphi) g(nphi+i)=gthetai
16902       enddo
16903       if (n.le.nphi+ntheta) goto 10
16904       do i=2,nres-1
16905       if (itype(i,1).ne.10) then
16906           galphai=0.0D0
16907         gomegai=0.0D0
16908         do k=1,3
16909           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16910           enddo
16911         do k=1,3
16912           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16913           enddo
16914           g(ialph(i,1))=galphai
16915         g(ialph(i,1)+nside)=gomegai
16916         endif
16917       enddo
16918 !
16919 ! Add the components corresponding to local energy terms.
16920 !
16921    10 continue
16922       do i=1,nvar
16923 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16924         g(i)=g(i)+gloc(i,icg)
16925       enddo
16926 ! Uncomment following three lines for diagnostics.
16927 !d    call intout
16928 !elwrite(iout,*) "in gradient after calling intout"
16929 !d    call briefout(0,0.0d0)
16930 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16931       return
16932       end subroutine gradient
16933 !-----------------------------------------------------------------------------
16934       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16935
16936       use comm_chu
16937 !      implicit real*8 (a-h,o-z)
16938 !      include 'DIMENSIONS'
16939 !      include 'COMMON.DERIV'
16940 !      include 'COMMON.IOUNITS'
16941 !      include 'COMMON.GEO'
16942       integer :: n,nf
16943 !el      integer :: jjj
16944 !el      common /chuju/ jjj
16945       real(kind=8) :: energia(0:n_ene)
16946       integer :: uiparm(1)
16947       real(kind=8) :: urparm(1)
16948       real(kind=8) :: f
16949       real(kind=8),external :: ufparm
16950       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16951 !     if (jjj.gt.0) then
16952 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16953 !     endif
16954       nfl=nf
16955       icg=mod(nf,2)+1
16956 !d      print *,'func',nf,nfl,icg
16957       call var_to_geom(n,x)
16958       call zerograd
16959       call chainbuild
16960 !d    write (iout,*) 'ETOTAL called from FUNC'
16961       call etotal(energia)
16962       call sum_gradient
16963       f=energia(0)
16964 !     if (jjj.gt.0) then
16965 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16966 !       write (iout,*) 'f=',etot
16967 !       jjj=0
16968 !     endif
16969       return
16970       end subroutine func
16971 !-----------------------------------------------------------------------------
16972       subroutine cartgrad
16973 !      implicit real*8 (a-h,o-z)
16974 !      include 'DIMENSIONS'
16975       use energy_data
16976       use MD_data, only: totT,usampl,eq_time
16977 #ifdef MPI
16978       include 'mpif.h'
16979 #endif
16980 !      include 'COMMON.CHAIN'
16981 !      include 'COMMON.DERIV'
16982 !      include 'COMMON.VAR'
16983 !      include 'COMMON.INTERACT'
16984 !      include 'COMMON.FFIELD'
16985 !      include 'COMMON.MD'
16986 !      include 'COMMON.IOUNITS'
16987 !      include 'COMMON.TIME1'
16988 !
16989       integer :: i,j
16990
16991 ! This subrouting calculates total Cartesian coordinate gradient.
16992 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16993 !
16994 !#define DEBUG
16995 #ifdef TIMING
16996       time00=MPI_Wtime()
16997 #endif
16998       icg=1
16999       call sum_gradient
17000 #ifdef TIMING
17001 #endif
17002 !#define DEBUG
17003 !el      write (iout,*) "After sum_gradient"
17004 #ifdef DEBUG
17005 !el      write (iout,*) "After sum_gradient"
17006       do i=1,nres-1
17007         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17008         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17009       enddo
17010 #endif
17011 !#undef DEBUG
17012 ! If performing constraint dynamics, add the gradients of the constraint energy
17013       if(usampl.and.totT.gt.eq_time) then
17014          do i=1,nct
17015            do j=1,3
17016              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17017              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17018            enddo
17019          enddo
17020          do i=1,nres-3
17021            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17022          enddo
17023          do i=1,nres-2
17024            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17025          enddo
17026       endif
17027 !elwrite (iout,*) "After sum_gradient"
17028 #ifdef TIMING
17029       time01=MPI_Wtime()
17030 #endif
17031       call intcartderiv
17032 !elwrite (iout,*) "After sum_gradient"
17033 #ifdef TIMING
17034       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17035 #endif
17036 !     call checkintcartgrad
17037 !     write(iout,*) 'calling int_to_cart'
17038 !#define DEBUG
17039 #ifdef DEBUG
17040       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17041 #endif
17042       do i=0,nct
17043         do j=1,3
17044           gcart(j,i)=gradc(j,i,icg)
17045           gxcart(j,i)=gradx(j,i,icg)
17046 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17047         enddo
17048 #ifdef DEBUG
17049         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17050           (gxcart(j,i),j=1,3),gloc(i,icg)
17051 #endif
17052       enddo
17053 #ifdef TIMING
17054       time01=MPI_Wtime()
17055 #endif
17056 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17057       call int_to_cart
17058 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17059
17060 #ifdef TIMING
17061             time_inttocart=time_inttocart+MPI_Wtime()-time01
17062 #endif
17063 #ifdef DEBUG
17064             write (iout,*) "gcart and gxcart after int_to_cart"
17065             do i=0,nres-1
17066             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17067                 (gxcart(j,i),j=1,3)
17068             enddo
17069 #endif
17070 !#undef DEBUG
17071 #ifdef CARGRAD
17072 #ifdef DEBUG
17073             write (iout,*) "CARGRAD"
17074 #endif
17075             do i=nres,0,-1
17076             do j=1,3
17077               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17078       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17079             enddo
17080       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17081       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17082             enddo
17083       ! Correction: dummy residues
17084             if (nnt.gt.1) then
17085               do j=1,3
17086       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17087                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17088               enddo
17089             endif
17090             if (nct.lt.nres) then
17091               do j=1,3
17092       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17093                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17094               enddo
17095             endif
17096 #endif
17097 #ifdef TIMING
17098             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17099 #endif
17100 !#undef DEBUG
17101             return
17102             end subroutine cartgrad
17103       !-----------------------------------------------------------------------------
17104             subroutine zerograd
17105       !      implicit real*8 (a-h,o-z)
17106       !      include 'DIMENSIONS'
17107       !      include 'COMMON.DERIV'
17108       !      include 'COMMON.CHAIN'
17109       !      include 'COMMON.VAR'
17110       !      include 'COMMON.MD'
17111       !      include 'COMMON.SCCOR'
17112       !
17113       !el local variables
17114             integer :: i,j,intertyp,k
17115       ! Initialize Cartesian-coordinate gradient
17116       !
17117       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17118       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17119
17120       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17121       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17122       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17123       !      allocate(gradcorr_long(3,nres))
17124       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17125       !      allocate(gcorr6_turn_long(3,nres))
17126       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17127
17128       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17129
17130       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17131       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17132
17133       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17134       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17135
17136       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17137       !      allocate(gscloc(3,nres)) !(3,maxres)
17138       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17139
17140
17141
17142       !      common /deriv_scloc/
17143       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17144       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17145       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17146       !      common /mpgrad/
17147       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17148
17149
17150
17151       !          gradc(j,i,icg)=0.0d0
17152       !          gradx(j,i,icg)=0.0d0
17153
17154       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17155       !elwrite(iout,*) "icg",icg
17156             do i=-1,nres
17157             do j=1,3
17158               gvdwx(j,i)=0.0D0
17159               gradx_scp(j,i)=0.0D0
17160               gvdwc(j,i)=0.0D0
17161               gvdwc_scp(j,i)=0.0D0
17162               gvdwc_scpp(j,i)=0.0d0
17163               gelc(j,i)=0.0D0
17164               gelc_long(j,i)=0.0D0
17165               gradb(j,i)=0.0d0
17166               gradbx(j,i)=0.0d0
17167               gvdwpp(j,i)=0.0d0
17168               gel_loc(j,i)=0.0d0
17169               gel_loc_long(j,i)=0.0d0
17170               ghpbc(j,i)=0.0D0
17171               ghpbx(j,i)=0.0D0
17172               gcorr3_turn(j,i)=0.0d0
17173               gcorr4_turn(j,i)=0.0d0
17174               gradcorr(j,i)=0.0d0
17175               gradcorr_long(j,i)=0.0d0
17176               gradcorr5_long(j,i)=0.0d0
17177               gradcorr6_long(j,i)=0.0d0
17178               gcorr6_turn_long(j,i)=0.0d0
17179               gradcorr5(j,i)=0.0d0
17180               gradcorr6(j,i)=0.0d0
17181               gcorr6_turn(j,i)=0.0d0
17182               gsccorc(j,i)=0.0d0
17183               gsccorx(j,i)=0.0d0
17184               gradc(j,i,icg)=0.0d0
17185               gradx(j,i,icg)=0.0d0
17186               gscloc(j,i)=0.0d0
17187               gsclocx(j,i)=0.0d0
17188               gliptran(j,i)=0.0d0
17189               gliptranx(j,i)=0.0d0
17190               gliptranc(j,i)=0.0d0
17191               gshieldx(j,i)=0.0d0
17192               gshieldc(j,i)=0.0d0
17193               gshieldc_loc(j,i)=0.0d0
17194               gshieldx_ec(j,i)=0.0d0
17195               gshieldc_ec(j,i)=0.0d0
17196               gshieldc_loc_ec(j,i)=0.0d0
17197               gshieldx_t3(j,i)=0.0d0
17198               gshieldc_t3(j,i)=0.0d0
17199               gshieldc_loc_t3(j,i)=0.0d0
17200               gshieldx_t4(j,i)=0.0d0
17201               gshieldc_t4(j,i)=0.0d0
17202               gshieldc_loc_t4(j,i)=0.0d0
17203               gshieldx_ll(j,i)=0.0d0
17204               gshieldc_ll(j,i)=0.0d0
17205               gshieldc_loc_ll(j,i)=0.0d0
17206               gg_tube(j,i)=0.0d0
17207               gg_tube_sc(j,i)=0.0d0
17208               gradafm(j,i)=0.0d0
17209               gradb_nucl(j,i)=0.0d0
17210               gradbx_nucl(j,i)=0.0d0
17211               gvdwpp_nucl(j,i)=0.0d0
17212               gvdwpp(j,i)=0.0d0
17213               gelpp(j,i)=0.0d0
17214               gvdwpsb(j,i)=0.0d0
17215               gvdwpsb1(j,i)=0.0d0
17216               gvdwsbc(j,i)=0.0d0
17217               gvdwsbx(j,i)=0.0d0
17218               gelsbc(j,i)=0.0d0
17219               gradcorr_nucl(j,i)=0.0d0
17220               gradcorr3_nucl(j,i)=0.0d0
17221               gradxorr_nucl(j,i)=0.0d0
17222               gradxorr3_nucl(j,i)=0.0d0
17223               gelsbx(j,i)=0.0d0
17224               gsbloc(j,i)=0.0d0
17225               gsblocx(j,i)=0.0d0
17226               gradpepcat(j,i)=0.0d0
17227               gradpepcatx(j,i)=0.0d0
17228               gradcatcat(j,i)=0.0d0
17229               gvdwx_scbase(j,i)=0.0d0
17230               gvdwc_scbase(j,i)=0.0d0
17231               gvdwx_pepbase(j,i)=0.0d0
17232               gvdwc_pepbase(j,i)=0.0d0
17233               gvdwx_scpho(j,i)=0.0d0
17234               gvdwc_scpho(j,i)=0.0d0
17235               gvdwc_peppho(j,i)=0.0d0
17236             enddo
17237              enddo
17238             do i=0,nres
17239             do j=1,3
17240               do intertyp=1,3
17241                gloc_sc(intertyp,i,icg)=0.0d0
17242               enddo
17243             enddo
17244             enddo
17245             do i=1,nres
17246              do j=1,maxcontsshi
17247              shield_list(j,i)=0
17248             do k=1,3
17249       !C           print *,i,j,k
17250                grad_shield_side(k,j,i)=0.0d0
17251                grad_shield_loc(k,j,i)=0.0d0
17252              enddo
17253              enddo
17254              ishield_list(i)=0
17255             enddo
17256
17257       !
17258       ! Initialize the gradient of local energy terms.
17259       !
17260       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17261       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17262       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17263       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17264       !      allocate(gel_loc_turn3(nres))
17265       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17266       !      allocate(gsccor_loc(nres))      !(maxres)
17267
17268             do i=1,4*nres
17269             gloc(i,icg)=0.0D0
17270             enddo
17271             do i=1,nres
17272             gel_loc_loc(i)=0.0d0
17273             gcorr_loc(i)=0.0d0
17274             g_corr5_loc(i)=0.0d0
17275             g_corr6_loc(i)=0.0d0
17276             gel_loc_turn3(i)=0.0d0
17277             gel_loc_turn4(i)=0.0d0
17278             gel_loc_turn6(i)=0.0d0
17279             gsccor_loc(i)=0.0d0
17280             enddo
17281       ! initialize gcart and gxcart
17282       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17283             do i=0,nres
17284             do j=1,3
17285               gcart(j,i)=0.0d0
17286               gxcart(j,i)=0.0d0
17287             enddo
17288             enddo
17289             return
17290             end subroutine zerograd
17291       !-----------------------------------------------------------------------------
17292             real(kind=8) function fdum()
17293             fdum=0.0D0
17294             return
17295             end function fdum
17296       !-----------------------------------------------------------------------------
17297       ! intcartderiv.F
17298       !-----------------------------------------------------------------------------
17299             subroutine intcartderiv
17300       !      implicit real*8 (a-h,o-z)
17301       !      include 'DIMENSIONS'
17302 #ifdef MPI
17303             include 'mpif.h'
17304 #endif
17305       !      include 'COMMON.SETUP'
17306       !      include 'COMMON.CHAIN'
17307       !      include 'COMMON.VAR'
17308       !      include 'COMMON.GEO'
17309       !      include 'COMMON.INTERACT'
17310       !      include 'COMMON.DERIV'
17311       !      include 'COMMON.IOUNITS'
17312       !      include 'COMMON.LOCAL'
17313       !      include 'COMMON.SCCOR'
17314             real(kind=8) :: pi4,pi34
17315             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17316             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17317                       dcosomega,dsinomega !(3,3,maxres)
17318             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17319
17320             integer :: i,j,k
17321             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17322                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17323                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17324                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17325             integer :: nres2
17326             nres2=2*nres
17327
17328       !el from module energy-------------
17329       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17330       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17331       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17332
17333       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17334       !el      allocate(dsintau(3,3,3,0:nres2))
17335       !el      allocate(dtauangle(3,3,3,0:nres2))
17336       !el      allocate(domicron(3,2,2,0:nres2))
17337       !el      allocate(dcosomicron(3,2,2,0:nres2))
17338
17339
17340
17341 #if defined(MPI) && defined(PARINTDER)
17342             if (nfgtasks.gt.1 .and. me.eq.king) &
17343             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17344 #endif
17345             pi4 = 0.5d0*pipol
17346             pi34 = 3*pi4
17347
17348       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17349       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17350
17351       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17352             do i=1,nres
17353             do j=1,3
17354               dtheta(j,1,i)=0.0d0
17355               dtheta(j,2,i)=0.0d0
17356               dphi(j,1,i)=0.0d0
17357               dphi(j,2,i)=0.0d0
17358               dphi(j,3,i)=0.0d0
17359             enddo
17360             enddo
17361       ! Derivatives of theta's
17362 #if defined(MPI) && defined(PARINTDER)
17363       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17364             do i=max0(ithet_start-1,3),ithet_end
17365 #else
17366             do i=3,nres
17367 #endif
17368             cost=dcos(theta(i))
17369             sint=sqrt(1-cost*cost)
17370             do j=1,3
17371               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17372               vbld(i-1)
17373               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17374               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17375               vbld(i)
17376               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17377             enddo
17378             enddo
17379 #if defined(MPI) && defined(PARINTDER)
17380       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17381             do i=max0(ithet_start-1,3),ithet_end
17382 #else
17383             do i=3,nres
17384 #endif
17385             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17386             cost1=dcos(omicron(1,i))
17387             sint1=sqrt(1-cost1*cost1)
17388             cost2=dcos(omicron(2,i))
17389             sint2=sqrt(1-cost2*cost2)
17390              do j=1,3
17391       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17392               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17393               cost1*dc_norm(j,i-2))/ &
17394               vbld(i-1)
17395               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17396               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17397               +cost1*(dc_norm(j,i-1+nres)))/ &
17398               vbld(i-1+nres)
17399               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17400       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17401       !C Looks messy but better than if in loop
17402               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17403               +cost2*dc_norm(j,i-1))/ &
17404               vbld(i)
17405               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17406               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17407                +cost2*(-dc_norm(j,i-1+nres)))/ &
17408               vbld(i-1+nres)
17409       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17410               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17411             enddo
17412              endif
17413             enddo
17414       !elwrite(iout,*) "after vbld write"
17415       ! Derivatives of phi:
17416       ! If phi is 0 or 180 degrees, then the formulas
17417       ! have to be derived by power series expansion of the
17418       ! conventional formulas around 0 and 180.
17419 #ifdef PARINTDER
17420             do i=iphi1_start,iphi1_end
17421 #else
17422             do i=4,nres
17423 #endif
17424       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17425       ! the conventional case
17426             sint=dsin(theta(i))
17427             sint1=dsin(theta(i-1))
17428             sing=dsin(phi(i))
17429             cost=dcos(theta(i))
17430             cost1=dcos(theta(i-1))
17431             cosg=dcos(phi(i))
17432             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17433             fac0=1.0d0/(sint1*sint)
17434             fac1=cost*fac0
17435             fac2=cost1*fac0
17436             fac3=cosg*cost1/(sint1*sint1)
17437             fac4=cosg*cost/(sint*sint)
17438       !    Obtaining the gamma derivatives from sine derivative
17439              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17440                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17441                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17442              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17443              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17444              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17445              do j=1,3
17446                 ctgt=cost/sint
17447                 ctgt1=cost1/sint1
17448                 cosg_inv=1.0d0/cosg
17449                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17450                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17451                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17452                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17453                 dsinphi(j,2,i)= &
17454                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17455                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17456                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17457                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17458                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17459       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17460                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17461                 endif
17462       ! Bug fixed 3/24/05 (AL)
17463              enddo
17464       !   Obtaining the gamma derivatives from cosine derivative
17465             else
17466                do j=1,3
17467                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17468                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17469                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17470                dc_norm(j,i-3))/vbld(i-2)
17471                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17472                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17473                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17474                dcostheta(j,1,i)
17475                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17476                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17477                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17478                dc_norm(j,i-1))/vbld(i)
17479                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17480 !#define DEBUG
17481 #ifdef DEBUG
17482                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17483 #endif
17484 !#undef DEBUG
17485                endif
17486              enddo
17487             endif
17488             enddo
17489       !alculate derivative of Tauangle
17490 #ifdef PARINTDER
17491             do i=itau_start,itau_end
17492 #else
17493             do i=3,nres
17494       !elwrite(iout,*) " vecpr",i,nres
17495 #endif
17496              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17497       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17498       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17499       !c dtauangle(j,intertyp,dervityp,residue number)
17500       !c INTERTYP=1 SC...Ca...Ca..Ca
17501       ! the conventional case
17502             sint=dsin(theta(i))
17503             sint1=dsin(omicron(2,i-1))
17504             sing=dsin(tauangle(1,i))
17505             cost=dcos(theta(i))
17506             cost1=dcos(omicron(2,i-1))
17507             cosg=dcos(tauangle(1,i))
17508       !elwrite(iout,*) " vecpr5",i,nres
17509             do j=1,3
17510       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17511       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17512             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17513       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17514             enddo
17515             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17516             fac0=1.0d0/(sint1*sint)
17517             fac1=cost*fac0
17518             fac2=cost1*fac0
17519             fac3=cosg*cost1/(sint1*sint1)
17520             fac4=cosg*cost/(sint*sint)
17521       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17522       !    Obtaining the gamma derivatives from sine derivative
17523              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17524                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17525                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17526              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17527              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17528              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17529             do j=1,3
17530                 ctgt=cost/sint
17531                 ctgt1=cost1/sint1
17532                 cosg_inv=1.0d0/cosg
17533                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17534              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17535              *vbld_inv(i-2+nres)
17536                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17537                 dsintau(j,1,2,i)= &
17538                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17539                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17540       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17541                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17542       ! Bug fixed 3/24/05 (AL)
17543                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17544                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17545       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17546                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17547              enddo
17548       !   Obtaining the gamma derivatives from cosine derivative
17549             else
17550                do j=1,3
17551                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17552                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17553                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17554                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17555                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17556                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17557                dcostheta(j,1,i)
17558                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17559                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17560                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17561                dc_norm(j,i-1))/vbld(i)
17562                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17563       !         write (iout,*) "else",i
17564              enddo
17565             endif
17566       !        do k=1,3
17567       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17568       !        enddo
17569             enddo
17570       !C Second case Ca...Ca...Ca...SC
17571 #ifdef PARINTDER
17572             do i=itau_start,itau_end
17573 #else
17574             do i=4,nres
17575 #endif
17576              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17577               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17578       ! the conventional case
17579             sint=dsin(omicron(1,i))
17580             sint1=dsin(theta(i-1))
17581             sing=dsin(tauangle(2,i))
17582             cost=dcos(omicron(1,i))
17583             cost1=dcos(theta(i-1))
17584             cosg=dcos(tauangle(2,i))
17585       !        do j=1,3
17586       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17587       !        enddo
17588             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17589             fac0=1.0d0/(sint1*sint)
17590             fac1=cost*fac0
17591             fac2=cost1*fac0
17592             fac3=cosg*cost1/(sint1*sint1)
17593             fac4=cosg*cost/(sint*sint)
17594       !    Obtaining the gamma derivatives from sine derivative
17595              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17596                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17597                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17598              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17599              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17600              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17601             do j=1,3
17602                 ctgt=cost/sint
17603                 ctgt1=cost1/sint1
17604                 cosg_inv=1.0d0/cosg
17605                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17606                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17607       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17608       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17609                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17610                 dsintau(j,2,2,i)= &
17611                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17612                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17613       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17614       !     & sing*ctgt*domicron(j,1,2,i),
17615       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17616                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17617       ! Bug fixed 3/24/05 (AL)
17618                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17619                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17620       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17621                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17622              enddo
17623       !   Obtaining the gamma derivatives from cosine derivative
17624             else
17625                do j=1,3
17626                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17627                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17628                dc_norm(j,i-3))/vbld(i-2)
17629                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17630                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17631                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17632                dcosomicron(j,1,1,i)
17633                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17634                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17635                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17636                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17637                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17638       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17639              enddo
17640             endif
17641             enddo
17642
17643       !CC third case SC...Ca...Ca...SC
17644 #ifdef PARINTDER
17645
17646             do i=itau_start,itau_end
17647 #else
17648             do i=3,nres
17649 #endif
17650       ! the conventional case
17651             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17652             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17653             sint=dsin(omicron(1,i))
17654             sint1=dsin(omicron(2,i-1))
17655             sing=dsin(tauangle(3,i))
17656             cost=dcos(omicron(1,i))
17657             cost1=dcos(omicron(2,i-1))
17658             cosg=dcos(tauangle(3,i))
17659             do j=1,3
17660             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17661       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17662             enddo
17663             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17664             fac0=1.0d0/(sint1*sint)
17665             fac1=cost*fac0
17666             fac2=cost1*fac0
17667             fac3=cosg*cost1/(sint1*sint1)
17668             fac4=cosg*cost/(sint*sint)
17669       !    Obtaining the gamma derivatives from sine derivative
17670              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17671                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17672                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17673              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17674              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17675              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17676             do j=1,3
17677                 ctgt=cost/sint
17678                 ctgt1=cost1/sint1
17679                 cosg_inv=1.0d0/cosg
17680                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17681                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17682                   *vbld_inv(i-2+nres)
17683                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17684                 dsintau(j,3,2,i)= &
17685                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17686                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17687                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17688       ! Bug fixed 3/24/05 (AL)
17689                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17690                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17691                   *vbld_inv(i-1+nres)
17692       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17693                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17694              enddo
17695       !   Obtaining the gamma derivatives from cosine derivative
17696             else
17697                do j=1,3
17698                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17699                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17700                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17701                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17702                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17703                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17704                dcosomicron(j,1,1,i)
17705                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17706                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17707                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17708                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17709                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17710       !          write(iout,*) "else",i
17711              enddo
17712             endif
17713             enddo
17714
17715 #ifdef CRYST_SC
17716       !   Derivatives of side-chain angles alpha and omega
17717 #if defined(MPI) && defined(PARINTDER)
17718             do i=ibond_start,ibond_end
17719 #else
17720             do i=2,nres-1
17721 #endif
17722               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17723                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17724                  fac6=fac5/vbld(i)
17725                  fac7=fac5*fac5
17726                  fac8=fac5/vbld(i+1)
17727                  fac9=fac5/vbld(i+nres)
17728                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17729                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17730                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17731                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17732                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17733                  sina=sqrt(1-cosa*cosa)
17734                  sino=dsin(omeg(i))
17735       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17736                  do j=1,3
17737                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17738                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17739                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17740                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17741                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17742                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17743                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17744                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17745                   vbld(i+nres))
17746                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17747                 enddo
17748       ! obtaining the derivatives of omega from sines
17749                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17750                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17751                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17752                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17753                    dsin(theta(i+1)))
17754                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17755                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17756                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17757                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17758                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17759                    coso_inv=1.0d0/dcos(omeg(i))
17760                    do j=1,3
17761                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17762                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17763                    (sino*dc_norm(j,i-1))/vbld(i)
17764                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17765                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17766                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17767                    -sino*dc_norm(j,i)/vbld(i+1)
17768                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17769                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17770                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17771                    vbld(i+nres)
17772                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17773                   enddo
17774                else
17775       !   obtaining the derivatives of omega from cosines
17776                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17777                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17778                  fac12=fac10*sina
17779                  fac13=fac12*fac12
17780                  fac14=sina*sina
17781                  do j=1,3
17782                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17783                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17784                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17785                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17786                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17787                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17788                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17789                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17790                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17791                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17792                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17793                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17794                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17795                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17796                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17797                 enddo
17798               endif
17799              else
17800                do j=1,3
17801                  do k=1,3
17802                    dalpha(k,j,i)=0.0d0
17803                    domega(k,j,i)=0.0d0
17804                  enddo
17805                enddo
17806              endif
17807              enddo
17808 #endif
17809 #if defined(MPI) && defined(PARINTDER)
17810             if (nfgtasks.gt.1) then
17811 #ifdef DEBUG
17812       !d      write (iout,*) "Gather dtheta"
17813       !d      call flush(iout)
17814             write (iout,*) "dtheta before gather"
17815             do i=1,nres
17816             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17817             enddo
17818 #endif
17819             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17820             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17821             king,FG_COMM,IERROR)
17822 !#define DEBUG
17823 #ifdef DEBUG
17824       !d      write (iout,*) "Gather dphi"
17825       !d      call flush(iout)
17826             write (iout,*) "dphi before gather"
17827             do i=1,nres
17828             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17829             enddo
17830 #endif
17831 !#undef DEBUG
17832             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17833             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17834             king,FG_COMM,IERROR)
17835       !d      write (iout,*) "Gather dalpha"
17836       !d      call flush(iout)
17837 #ifdef CRYST_SC
17838             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17839             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17840             king,FG_COMM,IERROR)
17841       !d      write (iout,*) "Gather domega"
17842       !d      call flush(iout)
17843             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17844             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17845             king,FG_COMM,IERROR)
17846 #endif
17847             endif
17848 #endif
17849 !#define DEBUG
17850 #ifdef DEBUG
17851             write (iout,*) "dtheta after gather"
17852             do i=1,nres
17853             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17854             enddo
17855             write (iout,*) "dphi after gather"
17856             do i=1,nres
17857             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17858             enddo
17859             write (iout,*) "dalpha after gather"
17860             do i=1,nres
17861             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17862             enddo
17863             write (iout,*) "domega after gather"
17864             do i=1,nres
17865             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17866             enddo
17867 #endif
17868 !#undef DEBUG
17869             return
17870             end subroutine intcartderiv
17871       !-----------------------------------------------------------------------------
17872             subroutine checkintcartgrad
17873       !      implicit real*8 (a-h,o-z)
17874       !      include 'DIMENSIONS'
17875 #ifdef MPI
17876             include 'mpif.h'
17877 #endif
17878       !      include 'COMMON.CHAIN'
17879       !      include 'COMMON.VAR'
17880       !      include 'COMMON.GEO'
17881       !      include 'COMMON.INTERACT'
17882       !      include 'COMMON.DERIV'
17883       !      include 'COMMON.IOUNITS'
17884       !      include 'COMMON.SETUP'
17885             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17886             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17887             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17888             real(kind=8),dimension(3) :: dc_norm_s
17889             real(kind=8) :: aincr=1.0d-5
17890             integer :: i,j
17891             real(kind=8) :: dcji
17892             do i=1,nres
17893             phi_s(i)=phi(i)
17894             theta_s(i)=theta(i)
17895             alph_s(i)=alph(i)
17896             omeg_s(i)=omeg(i)
17897             enddo
17898       ! Check theta gradient
17899             write (iout,*) &
17900              "Analytical (upper) and numerical (lower) gradient of theta"
17901             write (iout,*)
17902             do i=3,nres
17903             do j=1,3
17904               dcji=dc(j,i-2)
17905               dc(j,i-2)=dcji+aincr
17906               call chainbuild_cart
17907               call int_from_cart1(.false.)
17908           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17909           dc(j,i-2)=dcji
17910           dcji=dc(j,i-1)
17911           dc(j,i-1)=dc(j,i-1)+aincr
17912           call chainbuild_cart
17913           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17914           dc(j,i-1)=dcji
17915         enddo
17916 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17917 !el          (dtheta(j,2,i),j=1,3)
17918 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17919 !el          (dthetanum(j,2,i),j=1,3)
17920 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17921 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17922 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17923 !el        write (iout,*)
17924       enddo
17925 ! Check gamma gradient
17926       write (iout,*) &
17927        "Analytical (upper) and numerical (lower) gradient of gamma"
17928       do i=4,nres
17929         do j=1,3
17930           dcji=dc(j,i-3)
17931           dc(j,i-3)=dcji+aincr
17932           call chainbuild_cart
17933           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17934               dc(j,i-3)=dcji
17935           dcji=dc(j,i-2)
17936           dc(j,i-2)=dcji+aincr
17937           call chainbuild_cart
17938           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17939           dc(j,i-2)=dcji
17940           dcji=dc(j,i-1)
17941           dc(j,i-1)=dc(j,i-1)+aincr
17942           call chainbuild_cart
17943           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17944           dc(j,i-1)=dcji
17945         enddo
17946 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17947 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17948 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17949 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17950 !el        write (iout,'(5x,3(3f10.5,5x))') &
17951 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17952 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17953 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17954 !el        write (iout,*)
17955       enddo
17956 ! Check alpha gradient
17957       write (iout,*) &
17958        "Analytical (upper) and numerical (lower) gradient of alpha"
17959       do i=2,nres-1
17960        if(itype(i,1).ne.10) then
17961                  do j=1,3
17962                   dcji=dc(j,i-1)
17963                    dc(j,i-1)=dcji+aincr
17964               call chainbuild_cart
17965               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17966                  /aincr
17967                   dc(j,i-1)=dcji
17968               dcji=dc(j,i)
17969               dc(j,i)=dcji+aincr
17970               call chainbuild_cart
17971               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17972                  /aincr
17973               dc(j,i)=dcji
17974               dcji=dc(j,i+nres)
17975               dc(j,i+nres)=dc(j,i+nres)+aincr
17976               call chainbuild_cart
17977               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17978                  /aincr
17979              dc(j,i+nres)=dcji
17980             enddo
17981           endif
17982 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17983 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17984 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17985 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17986 !el        write (iout,'(5x,3(3f10.5,5x))') &
17987 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17988 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17989 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17990 !el        write (iout,*)
17991       enddo
17992 !     Check omega gradient
17993       write (iout,*) &
17994        "Analytical (upper) and numerical (lower) gradient of omega"
17995       do i=2,nres-1
17996        if(itype(i,1).ne.10) then
17997                  do j=1,3
17998                   dcji=dc(j,i-1)
17999                    dc(j,i-1)=dcji+aincr
18000               call chainbuild_cart
18001               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18002                  /aincr
18003                   dc(j,i-1)=dcji
18004               dcji=dc(j,i)
18005               dc(j,i)=dcji+aincr
18006               call chainbuild_cart
18007               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18008                  /aincr
18009               dc(j,i)=dcji
18010               dcji=dc(j,i+nres)
18011               dc(j,i+nres)=dc(j,i+nres)+aincr
18012               call chainbuild_cart
18013               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18014                  /aincr
18015              dc(j,i+nres)=dcji
18016             enddo
18017           endif
18018 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18019 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18020 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18021 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18022 !el        write (iout,'(5x,3(3f10.5,5x))') &
18023 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18024 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18025 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18026 !el        write (iout,*)
18027       enddo
18028       return
18029       end subroutine checkintcartgrad
18030 !-----------------------------------------------------------------------------
18031 ! q_measure.F
18032 !-----------------------------------------------------------------------------
18033       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18034 !      implicit real*8 (a-h,o-z)
18035 !      include 'DIMENSIONS'
18036 !      include 'COMMON.IOUNITS'
18037 !      include 'COMMON.CHAIN'
18038 !      include 'COMMON.INTERACT'
18039 !      include 'COMMON.VAR'
18040       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18041       integer :: kkk,nsep=3
18042       real(kind=8) :: qm      !dist,
18043       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18044       logical :: lprn=.false.
18045       logical :: flag
18046 !      real(kind=8) :: sigm,x
18047
18048 !el      sigm(x)=0.25d0*x     ! local function
18049       qqmax=1.0d10
18050       do kkk=1,nperm
18051       qq = 0.0d0
18052       nl=0
18053        if(flag) then
18054         do il=seg1+nsep,seg2
18055           do jl=seg1,il-nsep
18056             nl=nl+1
18057             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18058                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18059                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18060             dij=dist(il,jl)
18061             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18062             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18063               nl=nl+1
18064               d0ijCM=dsqrt( &
18065                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18066                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18067                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18068               dijCM=dist(il+nres,jl+nres)
18069               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18070             endif
18071             qq = qq+qqij+qqijCM
18072           enddo
18073         enddo
18074         qq = qq/nl
18075       else
18076       do il=seg1,seg2
18077         if((seg3-il).lt.3) then
18078              secseg=il+3
18079         else
18080              secseg=seg3
18081         endif
18082           do jl=secseg,seg4
18083             nl=nl+1
18084             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18085                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18086                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18087             dij=dist(il,jl)
18088             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18089             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18090               nl=nl+1
18091               d0ijCM=dsqrt( &
18092                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18093                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18094                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18095               dijCM=dist(il+nres,jl+nres)
18096               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18097             endif
18098             qq = qq+qqij+qqijCM
18099           enddo
18100         enddo
18101       qq = qq/nl
18102       endif
18103       if (qqmax.le.qq) qqmax=qq
18104       enddo
18105       qwolynes=1.0d0-qqmax
18106       return
18107       end function qwolynes
18108 !-----------------------------------------------------------------------------
18109       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18110 !      implicit real*8 (a-h,o-z)
18111 !      include 'DIMENSIONS'
18112 !      include 'COMMON.IOUNITS'
18113 !      include 'COMMON.CHAIN'
18114 !      include 'COMMON.INTERACT'
18115 !      include 'COMMON.VAR'
18116 !      include 'COMMON.MD'
18117       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18118       integer :: nsep=3, kkk
18119 !el      real(kind=8) :: dist
18120       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18121       logical :: lprn=.false.
18122       logical :: flag
18123       real(kind=8) :: sim,dd0,fac,ddqij
18124 !el      sigm(x)=0.25d0*x           ! local function
18125       do kkk=1,nperm
18126       do i=0,nres
18127         do j=1,3
18128           dqwol(j,i)=0.0d0
18129           dxqwol(j,i)=0.0d0
18130         enddo
18131       enddo
18132       nl=0
18133        if(flag) then
18134         do il=seg1+nsep,seg2
18135           do jl=seg1,il-nsep
18136             nl=nl+1
18137             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18138                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18139                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18140             dij=dist(il,jl)
18141             sim = 1.0d0/sigm(d0ij)
18142             sim = sim*sim
18143             dd0 = dij-d0ij
18144             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18145           do k=1,3
18146               ddqij = (c(k,il)-c(k,jl))*fac
18147               dqwol(k,il)=dqwol(k,il)+ddqij
18148               dqwol(k,jl)=dqwol(k,jl)-ddqij
18149             enddo
18150
18151             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18152               nl=nl+1
18153               d0ijCM=dsqrt( &
18154                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18155                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18156                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18157               dijCM=dist(il+nres,jl+nres)
18158               sim = 1.0d0/sigm(d0ijCM)
18159               sim = sim*sim
18160               dd0=dijCM-d0ijCM
18161               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18162               do k=1,3
18163                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18164                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18165                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18166               enddo
18167             endif
18168           enddo
18169         enddo
18170        else
18171         do il=seg1,seg2
18172         if((seg3-il).lt.3) then
18173              secseg=il+3
18174         else
18175              secseg=seg3
18176         endif
18177           do jl=secseg,seg4
18178             nl=nl+1
18179             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18180                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18181                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18182             dij=dist(il,jl)
18183             sim = 1.0d0/sigm(d0ij)
18184             sim = sim*sim
18185             dd0 = dij-d0ij
18186             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18187             do k=1,3
18188               ddqij = (c(k,il)-c(k,jl))*fac
18189               dqwol(k,il)=dqwol(k,il)+ddqij
18190               dqwol(k,jl)=dqwol(k,jl)-ddqij
18191             enddo
18192             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18193               nl=nl+1
18194               d0ijCM=dsqrt( &
18195                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18196                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18197                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18198               dijCM=dist(il+nres,jl+nres)
18199               sim = 1.0d0/sigm(d0ijCM)
18200               sim=sim*sim
18201               dd0 = dijCM-d0ijCM
18202               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18203               do k=1,3
18204                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18205                dxqwol(k,il)=dxqwol(k,il)+ddqij
18206                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18207               enddo
18208             endif
18209           enddo
18210         enddo
18211       endif
18212       enddo
18213        do i=0,nres
18214          do j=1,3
18215            dqwol(j,i)=dqwol(j,i)/nl
18216            dxqwol(j,i)=dxqwol(j,i)/nl
18217          enddo
18218        enddo
18219       return
18220       end subroutine qwolynes_prim
18221 !-----------------------------------------------------------------------------
18222       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18223 !      implicit real*8 (a-h,o-z)
18224 !      include 'DIMENSIONS'
18225 !      include 'COMMON.IOUNITS'
18226 !      include 'COMMON.CHAIN'
18227 !      include 'COMMON.INTERACT'
18228 !      include 'COMMON.VAR'
18229       integer :: seg1,seg2,seg3,seg4
18230       logical :: flag
18231       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18232       real(kind=8),dimension(3,0:2*nres) :: cdummy
18233       real(kind=8) :: q1,q2
18234       real(kind=8) :: delta=1.0d-10
18235       integer :: i,j
18236
18237       do i=0,nres
18238         do j=1,3
18239           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18240           cdummy(j,i)=c(j,i)
18241           c(j,i)=c(j,i)+delta
18242           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18243           qwolan(j,i)=(q2-q1)/delta
18244           c(j,i)=cdummy(j,i)
18245         enddo
18246       enddo
18247       do i=0,nres
18248         do j=1,3
18249           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18250           cdummy(j,i+nres)=c(j,i+nres)
18251           c(j,i+nres)=c(j,i+nres)+delta
18252           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18253           qwolxan(j,i)=(q2-q1)/delta
18254           c(j,i+nres)=cdummy(j,i+nres)
18255         enddo
18256       enddo
18257 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18258 !      do i=0,nct
18259 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18260 !      enddo
18261 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18262 !      do i=0,nct
18263 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18264 !      enddo
18265       return
18266       end subroutine qwol_num
18267 !-----------------------------------------------------------------------------
18268       subroutine EconstrQ
18269 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18270 !      implicit real*8 (a-h,o-z)
18271 !      include 'DIMENSIONS'
18272 !      include 'COMMON.CONTROL'
18273 !      include 'COMMON.VAR'
18274 !      include 'COMMON.MD'
18275       use MD_data
18276 !#ifndef LANG0
18277 !      include 'COMMON.LANGEVIN'
18278 !#else
18279 !      include 'COMMON.LANGEVIN.lang0'
18280 !#endif
18281 !      include 'COMMON.CHAIN'
18282 !      include 'COMMON.DERIV'
18283 !      include 'COMMON.GEO'
18284 !      include 'COMMON.LOCAL'
18285 !      include 'COMMON.INTERACT'
18286 !      include 'COMMON.IOUNITS'
18287 !      include 'COMMON.NAMES'
18288 !      include 'COMMON.TIME1'
18289       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18290       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18291                    duconst,duxconst
18292       integer :: kstart,kend,lstart,lend,idummy
18293       real(kind=8) :: delta=1.0d-7
18294       integer :: i,j,k,ii
18295       do i=0,nres
18296          do j=1,3
18297             duconst(j,i)=0.0d0
18298             dudconst(j,i)=0.0d0
18299             duxconst(j,i)=0.0d0
18300             dudxconst(j,i)=0.0d0
18301          enddo
18302       enddo
18303       Uconst=0.0d0
18304       do i=1,nfrag
18305          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18306            idummy,idummy)
18307          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18308 ! Calculating the derivatives of Constraint energy with respect to Q
18309          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18310            qinfrag(i,iset))
18311 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18312 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18313 !         hmnum=(hm2-hm1)/delta
18314 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18315 !     &   qinfrag(i,iset))
18316 !         write(iout,*) "harmonicnum frag", hmnum
18317 ! Calculating the derivatives of Q with respect to cartesian coordinates
18318          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18319           idummy,idummy)
18320 !         write(iout,*) "dqwol "
18321 !         do ii=1,nres
18322 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18323 !         enddo
18324 !         write(iout,*) "dxqwol "
18325 !         do ii=1,nres
18326 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18327 !         enddo
18328 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18329 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18330 !     &  ,idummy,idummy)
18331 !  The gradients of Uconst in Cs
18332          do ii=0,nres
18333             do j=1,3
18334                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18335                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18336             enddo
18337          enddo
18338       enddo
18339       do i=1,npair
18340          kstart=ifrag(1,ipair(1,i,iset),iset)
18341          kend=ifrag(2,ipair(1,i,iset),iset)
18342          lstart=ifrag(1,ipair(2,i,iset),iset)
18343          lend=ifrag(2,ipair(2,i,iset),iset)
18344          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18345          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18346 !  Calculating dU/dQ
18347          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18348 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18349 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18350 !         hmnum=(hm2-hm1)/delta
18351 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18352 !     &   qinpair(i,iset))
18353 !         write(iout,*) "harmonicnum pair ", hmnum
18354 ! Calculating dQ/dXi
18355          call qwolynes_prim(kstart,kend,.false.,&
18356           lstart,lend)
18357 !         write(iout,*) "dqwol "
18358 !         do ii=1,nres
18359 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18360 !         enddo
18361 !         write(iout,*) "dxqwol "
18362 !         do ii=1,nres
18363 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18364 !        enddo
18365 ! Calculating numerical gradients
18366 !        call qwol_num(kstart,kend,.false.
18367 !     &  ,lstart,lend)
18368 ! The gradients of Uconst in Cs
18369          do ii=0,nres
18370             do j=1,3
18371                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18372                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18373             enddo
18374          enddo
18375       enddo
18376 !      write(iout,*) "Uconst inside subroutine ", Uconst
18377 ! Transforming the gradients from Cs to dCs for the backbone
18378       do i=0,nres
18379          do j=i+1,nres
18380            do k=1,3
18381              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18382            enddo
18383          enddo
18384       enddo
18385 !  Transforming the gradients from Cs to dCs for the side chains
18386       do i=1,nres
18387          do j=1,3
18388            dudxconst(j,i)=duxconst(j,i)
18389          enddo
18390       enddo
18391 !      write(iout,*) "dU/ddc backbone "
18392 !       do ii=0,nres
18393 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18394 !      enddo
18395 !      write(iout,*) "dU/ddX side chain "
18396 !      do ii=1,nres
18397 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18398 !      enddo
18399 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18400 !      call dEconstrQ_num
18401       return
18402       end subroutine EconstrQ
18403 !-----------------------------------------------------------------------------
18404       subroutine dEconstrQ_num
18405 ! Calculating numerical dUconst/ddc and dUconst/ddx
18406 !      implicit real*8 (a-h,o-z)
18407 !      include 'DIMENSIONS'
18408 !      include 'COMMON.CONTROL'
18409 !      include 'COMMON.VAR'
18410 !      include 'COMMON.MD'
18411       use MD_data
18412 !#ifndef LANG0
18413 !      include 'COMMON.LANGEVIN'
18414 !#else
18415 !      include 'COMMON.LANGEVIN.lang0'
18416 !#endif
18417 !      include 'COMMON.CHAIN'
18418 !      include 'COMMON.DERIV'
18419 !      include 'COMMON.GEO'
18420 !      include 'COMMON.LOCAL'
18421 !      include 'COMMON.INTERACT'
18422 !      include 'COMMON.IOUNITS'
18423 !      include 'COMMON.NAMES'
18424 !      include 'COMMON.TIME1'
18425       real(kind=8) :: uzap1,uzap2
18426       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18427       integer :: kstart,kend,lstart,lend,idummy
18428       real(kind=8) :: delta=1.0d-7
18429 !el local variables
18430       integer :: i,ii,j
18431 !     real(kind=8) ::
18432 !     For the backbone
18433       do i=0,nres-1
18434          do j=1,3
18435             dUcartan(j,i)=0.0d0
18436             cdummy(j,i)=dc(j,i)
18437             dc(j,i)=dc(j,i)+delta
18438             call chainbuild_cart
18439           uzap2=0.0d0
18440             do ii=1,nfrag
18441              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18442                 idummy,idummy)
18443                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18444                 qinfrag(ii,iset))
18445             enddo
18446             do ii=1,npair
18447                kstart=ifrag(1,ipair(1,ii,iset),iset)
18448                kend=ifrag(2,ipair(1,ii,iset),iset)
18449                lstart=ifrag(1,ipair(2,ii,iset),iset)
18450                lend=ifrag(2,ipair(2,ii,iset),iset)
18451                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18452                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18453                  qinpair(ii,iset))
18454             enddo
18455             dc(j,i)=cdummy(j,i)
18456             call chainbuild_cart
18457             uzap1=0.0d0
18458              do ii=1,nfrag
18459              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18460                 idummy,idummy)
18461                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18462                 qinfrag(ii,iset))
18463             enddo
18464             do ii=1,npair
18465                kstart=ifrag(1,ipair(1,ii,iset),iset)
18466                kend=ifrag(2,ipair(1,ii,iset),iset)
18467                lstart=ifrag(1,ipair(2,ii,iset),iset)
18468                lend=ifrag(2,ipair(2,ii,iset),iset)
18469                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18470                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18471                 qinpair(ii,iset))
18472             enddo
18473             ducartan(j,i)=(uzap2-uzap1)/(delta)
18474          enddo
18475       enddo
18476 ! Calculating numerical gradients for dU/ddx
18477       do i=0,nres-1
18478          duxcartan(j,i)=0.0d0
18479          do j=1,3
18480             cdummy(j,i)=dc(j,i+nres)
18481             dc(j,i+nres)=dc(j,i+nres)+delta
18482             call chainbuild_cart
18483           uzap2=0.0d0
18484             do ii=1,nfrag
18485              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18486                 idummy,idummy)
18487                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18488                 qinfrag(ii,iset))
18489             enddo
18490             do ii=1,npair
18491                kstart=ifrag(1,ipair(1,ii,iset),iset)
18492                kend=ifrag(2,ipair(1,ii,iset),iset)
18493                lstart=ifrag(1,ipair(2,ii,iset),iset)
18494                lend=ifrag(2,ipair(2,ii,iset),iset)
18495                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18496                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18497                 qinpair(ii,iset))
18498             enddo
18499             dc(j,i+nres)=cdummy(j,i)
18500             call chainbuild_cart
18501             uzap1=0.0d0
18502              do ii=1,nfrag
18503                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18504                 ifrag(2,ii,iset),.true.,idummy,idummy)
18505                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18506                 qinfrag(ii,iset))
18507             enddo
18508             do ii=1,npair
18509                kstart=ifrag(1,ipair(1,ii,iset),iset)
18510                kend=ifrag(2,ipair(1,ii,iset),iset)
18511                lstart=ifrag(1,ipair(2,ii,iset),iset)
18512                lend=ifrag(2,ipair(2,ii,iset),iset)
18513                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18514                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18515                 qinpair(ii,iset))
18516             enddo
18517             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18518          enddo
18519       enddo
18520       write(iout,*) "Numerical dUconst/ddc backbone "
18521       do ii=0,nres
18522         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18523       enddo
18524 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18525 !      do ii=1,nres
18526 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18527 !      enddo
18528       return
18529       end subroutine dEconstrQ_num
18530 !-----------------------------------------------------------------------------
18531 ! ssMD.F
18532 !-----------------------------------------------------------------------------
18533       subroutine check_energies
18534
18535 !      use random, only: ran_number
18536
18537 !      implicit none
18538 !     Includes
18539 !      include 'DIMENSIONS'
18540 !      include 'COMMON.CHAIN'
18541 !      include 'COMMON.VAR'
18542 !      include 'COMMON.IOUNITS'
18543 !      include 'COMMON.SBRIDGE'
18544 !      include 'COMMON.LOCAL'
18545 !      include 'COMMON.GEO'
18546
18547 !     External functions
18548 !EL      double precision ran_number
18549 !EL      external ran_number
18550
18551 !     Local variables
18552       integer :: i,j,k,l,lmax,p,pmax
18553       real(kind=8) :: rmin,rmax
18554       real(kind=8) :: eij
18555
18556       real(kind=8) :: d
18557       real(kind=8) :: wi,rij,tj,pj
18558 !      return
18559
18560       i=5
18561       j=14
18562
18563       d=dsc(1)
18564       rmin=2.0D0
18565       rmax=12.0D0
18566
18567       lmax=10000
18568       pmax=1
18569
18570       do k=1,3
18571         c(k,i)=0.0D0
18572         c(k,j)=0.0D0
18573         c(k,nres+i)=0.0D0
18574         c(k,nres+j)=0.0D0
18575       enddo
18576
18577       do l=1,lmax
18578
18579 !t        wi=ran_number(0.0D0,pi)
18580 !        wi=ran_number(0.0D0,pi/6.0D0)
18581 !        wi=0.0D0
18582 !t        tj=ran_number(0.0D0,pi)
18583 !t        pj=ran_number(0.0D0,pi)
18584 !        pj=ran_number(0.0D0,pi/6.0D0)
18585 !        pj=0.0D0
18586
18587         do p=1,pmax
18588 !t           rij=ran_number(rmin,rmax)
18589
18590            c(1,j)=d*sin(pj)*cos(tj)
18591            c(2,j)=d*sin(pj)*sin(tj)
18592            c(3,j)=d*cos(pj)
18593
18594            c(3,nres+i)=-rij
18595
18596            c(1,i)=d*sin(wi)
18597            c(3,i)=-rij-d*cos(wi)
18598
18599            do k=1,3
18600               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18601               dc_norm(k,nres+i)=dc(k,nres+i)/d
18602               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18603               dc_norm(k,nres+j)=dc(k,nres+j)/d
18604            enddo
18605
18606            call dyn_ssbond_ene(i,j,eij)
18607         enddo
18608       enddo
18609       call exit(1)
18610       return
18611       end subroutine check_energies
18612 !-----------------------------------------------------------------------------
18613       subroutine dyn_ssbond_ene(resi,resj,eij)
18614 !      implicit none
18615 !      Includes
18616       use calc_data
18617       use comm_sschecks
18618 !      include 'DIMENSIONS'
18619 !      include 'COMMON.SBRIDGE'
18620 !      include 'COMMON.CHAIN'
18621 !      include 'COMMON.DERIV'
18622 !      include 'COMMON.LOCAL'
18623 !      include 'COMMON.INTERACT'
18624 !      include 'COMMON.VAR'
18625 !      include 'COMMON.IOUNITS'
18626 !      include 'COMMON.CALC'
18627 #ifndef CLUST
18628 #ifndef WHAM
18629        use MD_data
18630 !      include 'COMMON.MD'
18631 !      use MD, only: totT,t_bath
18632 #endif
18633 #endif
18634 !     External functions
18635 !EL      double precision h_base
18636 !EL      external h_base
18637
18638 !     Input arguments
18639       integer :: resi,resj
18640
18641 !     Output arguments
18642       real(kind=8) :: eij
18643
18644 !     Local variables
18645       logical :: havebond
18646       integer itypi,itypj
18647       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18648       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18649       real(kind=8),dimension(3) :: dcosom1,dcosom2
18650       real(kind=8) :: ed
18651       real(kind=8) :: pom1,pom2
18652       real(kind=8) :: ljA,ljB,ljXs
18653       real(kind=8),dimension(1:3) :: d_ljB
18654       real(kind=8) :: ssA,ssB,ssC,ssXs
18655       real(kind=8) :: ssxm,ljxm,ssm,ljm
18656       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18657       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18658       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18659 !-------FIRST METHOD
18660       real(kind=8) :: xm
18661       real(kind=8),dimension(1:3) :: d_xm
18662 !-------END FIRST METHOD
18663 !-------SECOND METHOD
18664 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18665 !-------END SECOND METHOD
18666
18667 !-------TESTING CODE
18668 !el      logical :: checkstop,transgrad
18669 !el      common /sschecks/ checkstop,transgrad
18670
18671       integer :: icheck,nicheck,jcheck,njcheck
18672       real(kind=8),dimension(-1:1) :: echeck
18673       real(kind=8) :: deps,ssx0,ljx0
18674 !-------END TESTING CODE
18675
18676       eij=0.0d0
18677       i=resi
18678       j=resj
18679
18680 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18681 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18682
18683       itypi=itype(i,1)
18684       dxi=dc_norm(1,nres+i)
18685       dyi=dc_norm(2,nres+i)
18686       dzi=dc_norm(3,nres+i)
18687       dsci_inv=vbld_inv(i+nres)
18688
18689       itypj=itype(j,1)
18690       xj=c(1,nres+j)-c(1,nres+i)
18691       yj=c(2,nres+j)-c(2,nres+i)
18692       zj=c(3,nres+j)-c(3,nres+i)
18693       dxj=dc_norm(1,nres+j)
18694       dyj=dc_norm(2,nres+j)
18695       dzj=dc_norm(3,nres+j)
18696       dscj_inv=vbld_inv(j+nres)
18697
18698       chi1=chi(itypi,itypj)
18699       chi2=chi(itypj,itypi)
18700       chi12=chi1*chi2
18701       chip1=chip(itypi)
18702       chip2=chip(itypj)
18703       chip12=chip1*chip2
18704       alf1=alp(itypi)
18705       alf2=alp(itypj)
18706       alf12=0.5D0*(alf1+alf2)
18707
18708       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18709       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18710 !     The following are set in sc_angular
18711 !      erij(1)=xj*rij
18712 !      erij(2)=yj*rij
18713 !      erij(3)=zj*rij
18714 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18715 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18716 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18717       call sc_angular
18718       rij=1.0D0/rij  ! Reset this so it makes sense
18719
18720       sig0ij=sigma(itypi,itypj)
18721       sig=sig0ij*dsqrt(1.0D0/sigsq)
18722
18723       ljXs=sig-sig0ij
18724       ljA=eps1*eps2rt**2*eps3rt**2
18725       ljB=ljA*bb_aq(itypi,itypj)
18726       ljA=ljA*aa_aq(itypi,itypj)
18727       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18728
18729       ssXs=d0cm
18730       deltat1=1.0d0-om1
18731       deltat2=1.0d0+om2
18732       deltat12=om2-om1+2.0d0
18733       cosphi=om12-om1*om2
18734       ssA=akcm
18735       ssB=akct*deltat12
18736       ssC=ss_depth &
18737            +akth*(deltat1*deltat1+deltat2*deltat2) &
18738            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18739       ssxm=ssXs-0.5D0*ssB/ssA
18740
18741 !-------TESTING CODE
18742 !$$$c     Some extra output
18743 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18744 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18745 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18746 !$$$      if (ssx0.gt.0.0d0) then
18747 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18748 !$$$      else
18749 !$$$        ssx0=ssxm
18750 !$$$      endif
18751 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18752 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18753 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18754 !$$$      return
18755 !-------END TESTING CODE
18756
18757 !-------TESTING CODE
18758 !     Stop and plot energy and derivative as a function of distance
18759       if (checkstop) then
18760         ssm=ssC-0.25D0*ssB*ssB/ssA
18761         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18762         if (ssm.lt.ljm .and. &
18763              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18764           nicheck=1000
18765           njcheck=1
18766           deps=0.5d-7
18767         else
18768           checkstop=.false.
18769         endif
18770       endif
18771       if (.not.checkstop) then
18772         nicheck=0
18773         njcheck=-1
18774       endif
18775
18776       do icheck=0,nicheck
18777       do jcheck=-1,njcheck
18778       if (checkstop) rij=(ssxm-1.0d0)+ &
18779              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18780 !-------END TESTING CODE
18781
18782       if (rij.gt.ljxm) then
18783         havebond=.false.
18784         ljd=rij-ljXs
18785         fac=(1.0D0/ljd)**expon
18786         e1=fac*fac*aa_aq(itypi,itypj)
18787         e2=fac*bb_aq(itypi,itypj)
18788         eij=eps1*eps2rt*eps3rt*(e1+e2)
18789         eps2der=eij*eps3rt
18790         eps3der=eij*eps2rt
18791         eij=eij*eps2rt*eps3rt
18792
18793         sigder=-sig/sigsq
18794         e1=e1*eps1*eps2rt**2*eps3rt**2
18795         ed=-expon*(e1+eij)/ljd
18796         sigder=ed*sigder
18797         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18798         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18799         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18800              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18801       else if (rij.lt.ssxm) then
18802         havebond=.true.
18803         ssd=rij-ssXs
18804         eij=ssA*ssd*ssd+ssB*ssd+ssC
18805
18806         ed=2*akcm*ssd+akct*deltat12
18807         pom1=akct*ssd
18808         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18809         eom1=-2*akth*deltat1-pom1-om2*pom2
18810         eom2= 2*akth*deltat2+pom1-om1*pom2
18811         eom12=pom2
18812       else
18813         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18814
18815         d_ssxm(1)=0.5D0*akct/ssA
18816         d_ssxm(2)=-d_ssxm(1)
18817         d_ssxm(3)=0.0D0
18818
18819         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18820         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18821         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18822         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18823
18824 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18825         xm=0.5d0*(ssxm+ljxm)
18826         do k=1,3
18827           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18828         enddo
18829         if (rij.lt.xm) then
18830           havebond=.true.
18831           ssm=ssC-0.25D0*ssB*ssB/ssA
18832           d_ssm(1)=0.5D0*akct*ssB/ssA
18833           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18834           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18835           d_ssm(3)=omega
18836           f1=(rij-xm)/(ssxm-xm)
18837           f2=(rij-ssxm)/(xm-ssxm)
18838           h1=h_base(f1,hd1)
18839           h2=h_base(f2,hd2)
18840           eij=ssm*h1+Ht*h2
18841           delta_inv=1.0d0/(xm-ssxm)
18842           deltasq_inv=delta_inv*delta_inv
18843           fac=ssm*hd1-Ht*hd2
18844           fac1=deltasq_inv*fac*(xm-rij)
18845           fac2=deltasq_inv*fac*(rij-ssxm)
18846           ed=delta_inv*(Ht*hd2-ssm*hd1)
18847           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18848           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18849           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18850         else
18851           havebond=.false.
18852           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18853           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18854           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18855           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18856                alf12/eps3rt)
18857           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18858           f1=(rij-ljxm)/(xm-ljxm)
18859           f2=(rij-xm)/(ljxm-xm)
18860           h1=h_base(f1,hd1)
18861           h2=h_base(f2,hd2)
18862           eij=Ht*h1+ljm*h2
18863           delta_inv=1.0d0/(ljxm-xm)
18864           deltasq_inv=delta_inv*delta_inv
18865           fac=Ht*hd1-ljm*hd2
18866           fac1=deltasq_inv*fac*(ljxm-rij)
18867           fac2=deltasq_inv*fac*(rij-xm)
18868           ed=delta_inv*(ljm*hd2-Ht*hd1)
18869           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18870           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18871           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18872         endif
18873 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18874
18875 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18876 !$$$        ssd=rij-ssXs
18877 !$$$        ljd=rij-ljXs
18878 !$$$        fac1=rij-ljxm
18879 !$$$        fac2=rij-ssxm
18880 !$$$
18881 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18882 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18883 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18884 !$$$
18885 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18886 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18887 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18888 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18889 !$$$        d_ssm(3)=omega
18890 !$$$
18891 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18892 !$$$        do k=1,3
18893 !$$$          d_ljm(k)=ljm*d_ljB(k)
18894 !$$$        enddo
18895 !$$$        ljm=ljm*ljB
18896 !$$$
18897 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18898 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18899 !$$$        d_ss(2)=akct*ssd
18900 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18901 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18902 !$$$        d_ss(3)=omega
18903 !$$$
18904 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18905 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18906 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18907 !$$$        do k=1,3
18908 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18909 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18910 !$$$        enddo
18911 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18912 !$$$
18913 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18914 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18915 !$$$        h1=h_base(f1,hd1)
18916 !$$$        h2=h_base(f2,hd2)
18917 !$$$        eij=ss*h1+ljf*h2
18918 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18919 !$$$        deltasq_inv=delta_inv*delta_inv
18920 !$$$        fac=ljf*hd2-ss*hd1
18921 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18922 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18923 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18924 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18925 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18926 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18927 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18928 !$$$
18929 !$$$        havebond=.false.
18930 !$$$        if (ed.gt.0.0d0) havebond=.true.
18931 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18932
18933       endif
18934
18935       if (havebond) then
18936 !#ifndef CLUST
18937 !#ifndef WHAM
18938 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18939 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18940 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18941 !        endif
18942 !#endif
18943 !#endif
18944         dyn_ssbond_ij(i,j)=eij
18945       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18946         dyn_ssbond_ij(i,j)=1.0d300
18947 !#ifndef CLUST
18948 !#ifndef WHAM
18949 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18950 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18951 !#endif
18952 !#endif
18953       endif
18954
18955 !-------TESTING CODE
18956 !el      if (checkstop) then
18957         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18958              "CHECKSTOP",rij,eij,ed
18959         echeck(jcheck)=eij
18960 !el      endif
18961       enddo
18962       if (checkstop) then
18963         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18964       endif
18965       enddo
18966       if (checkstop) then
18967         transgrad=.true.
18968         checkstop=.false.
18969       endif
18970 !-------END TESTING CODE
18971
18972       do k=1,3
18973         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18974         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18975       enddo
18976       do k=1,3
18977         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18978       enddo
18979       do k=1,3
18980         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18981              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18982              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18983         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18984              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18985              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18986       enddo
18987 !grad      do k=i,j-1
18988 !grad        do l=1,3
18989 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18990 !grad        enddo
18991 !grad      enddo
18992
18993       do l=1,3
18994         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18995         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18996       enddo
18997
18998       return
18999       end subroutine dyn_ssbond_ene
19000 !--------------------------------------------------------------------------
19001          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19002 !      implicit none
19003 !      Includes
19004       use calc_data
19005       use comm_sschecks
19006 !      include 'DIMENSIONS'
19007 !      include 'COMMON.SBRIDGE'
19008 !      include 'COMMON.CHAIN'
19009 !      include 'COMMON.DERIV'
19010 !      include 'COMMON.LOCAL'
19011 !      include 'COMMON.INTERACT'
19012 !      include 'COMMON.VAR'
19013 !      include 'COMMON.IOUNITS'
19014 !      include 'COMMON.CALC'
19015 #ifndef CLUST
19016 #ifndef WHAM
19017        use MD_data
19018 !      include 'COMMON.MD'
19019 !      use MD, only: totT,t_bath
19020 #endif
19021 #endif
19022       double precision h_base
19023       external h_base
19024
19025 !c     Input arguments
19026       integer resi,resj,resk,m,itypi,itypj,itypk
19027
19028 !c     Output arguments
19029       double precision eij,eij1,eij2,eij3
19030
19031 !c     Local variables
19032       logical havebond
19033 !c      integer itypi,itypj,k,l
19034       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19035       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19036       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19037       double precision sig0ij,ljd,sig,fac,e1,e2
19038       double precision dcosom1(3),dcosom2(3),ed
19039       double precision pom1,pom2
19040       double precision ljA,ljB,ljXs
19041       double precision d_ljB(1:3)
19042       double precision ssA,ssB,ssC,ssXs
19043       double precision ssxm,ljxm,ssm,ljm
19044       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19045       eij=0.0
19046       if (dtriss.eq.0) return
19047       i=resi
19048       j=resj
19049       k=resk
19050 !C      write(iout,*) resi,resj,resk
19051       itypi=itype(i,1)
19052       dxi=dc_norm(1,nres+i)
19053       dyi=dc_norm(2,nres+i)
19054       dzi=dc_norm(3,nres+i)
19055       dsci_inv=vbld_inv(i+nres)
19056       xi=c(1,nres+i)
19057       yi=c(2,nres+i)
19058       zi=c(3,nres+i)
19059       itypj=itype(j,1)
19060       xj=c(1,nres+j)
19061       yj=c(2,nres+j)
19062       zj=c(3,nres+j)
19063
19064       dxj=dc_norm(1,nres+j)
19065       dyj=dc_norm(2,nres+j)
19066       dzj=dc_norm(3,nres+j)
19067       dscj_inv=vbld_inv(j+nres)
19068       itypk=itype(k,1)
19069       xk=c(1,nres+k)
19070       yk=c(2,nres+k)
19071       zk=c(3,nres+k)
19072
19073       dxk=dc_norm(1,nres+k)
19074       dyk=dc_norm(2,nres+k)
19075       dzk=dc_norm(3,nres+k)
19076       dscj_inv=vbld_inv(k+nres)
19077       xij=xj-xi
19078       xik=xk-xi
19079       xjk=xk-xj
19080       yij=yj-yi
19081       yik=yk-yi
19082       yjk=yk-yj
19083       zij=zj-zi
19084       zik=zk-zi
19085       zjk=zk-zj
19086       rrij=(xij*xij+yij*yij+zij*zij)
19087       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19088       rrik=(xik*xik+yik*yik+zik*zik)
19089       rik=dsqrt(rrik)
19090       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19091       rjk=dsqrt(rrjk)
19092 !C there are three combination of distances for each trisulfide bonds
19093 !C The first case the ith atom is the center
19094 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19095 !C distance y is second distance the a,b,c,d are parameters derived for
19096 !C this problem d parameter was set as a penalty currenlty set to 1.
19097       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19098       eij1=0.0d0
19099       else
19100       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19101       endif
19102 !C second case jth atom is center
19103       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19104       eij2=0.0d0
19105       else
19106       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19107       endif
19108 !C the third case kth atom is the center
19109       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19110       eij3=0.0d0
19111       else
19112       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19113       endif
19114 !C      eij2=0.0
19115 !C      eij3=0.0
19116 !C      eij1=0.0
19117       eij=eij1+eij2+eij3
19118 !C      write(iout,*)i,j,k,eij
19119 !C The energy penalty calculated now time for the gradient part
19120 !C derivative over rij
19121       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19122       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19123             gg(1)=xij*fac/rij
19124             gg(2)=yij*fac/rij
19125             gg(3)=zij*fac/rij
19126       do m=1,3
19127         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19128         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19129       enddo
19130
19131       do l=1,3
19132         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19133         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19134       enddo
19135 !C now derivative over rik
19136       fac=-eij1**2/dtriss* &
19137       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19138       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19139             gg(1)=xik*fac/rik
19140             gg(2)=yik*fac/rik
19141             gg(3)=zik*fac/rik
19142       do m=1,3
19143         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19144         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19145       enddo
19146       do l=1,3
19147         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19148         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19149       enddo
19150 !C now derivative over rjk
19151       fac=-eij2**2/dtriss* &
19152       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19153       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19154             gg(1)=xjk*fac/rjk
19155             gg(2)=yjk*fac/rjk
19156             gg(3)=zjk*fac/rjk
19157       do m=1,3
19158         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19159         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19160       enddo
19161       do l=1,3
19162         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19163         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19164       enddo
19165       return
19166       end subroutine triple_ssbond_ene
19167
19168
19169
19170 !-----------------------------------------------------------------------------
19171       real(kind=8) function h_base(x,deriv)
19172 !     A smooth function going 0->1 in range [0,1]
19173 !     It should NOT be called outside range [0,1], it will not work there.
19174       implicit none
19175
19176 !     Input arguments
19177       real(kind=8) :: x
19178
19179 !     Output arguments
19180       real(kind=8) :: deriv
19181
19182 !     Local variables
19183       real(kind=8) :: xsq
19184
19185
19186 !     Two parabolas put together.  First derivative zero at extrema
19187 !$$$      if (x.lt.0.5D0) then
19188 !$$$        h_base=2.0D0*x*x
19189 !$$$        deriv=4.0D0*x
19190 !$$$      else
19191 !$$$        deriv=1.0D0-x
19192 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19193 !$$$        deriv=4.0D0*deriv
19194 !$$$      endif
19195
19196 !     Third degree polynomial.  First derivative zero at extrema
19197       h_base=x*x*(3.0d0-2.0d0*x)
19198       deriv=6.0d0*x*(1.0d0-x)
19199
19200 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19201 !$$$      xsq=x*x
19202 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19203 !$$$      deriv=x-1.0d0
19204 !$$$      deriv=deriv*deriv
19205 !$$$      deriv=30.0d0*xsq*deriv
19206
19207       return
19208       end function h_base
19209 !-----------------------------------------------------------------------------
19210       subroutine dyn_set_nss
19211 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19212 !      implicit none
19213       use MD_data, only: totT,t_bath
19214 !     Includes
19215 !      include 'DIMENSIONS'
19216 #ifdef MPI
19217       include "mpif.h"
19218 #endif
19219 !      include 'COMMON.SBRIDGE'
19220 !      include 'COMMON.CHAIN'
19221 !      include 'COMMON.IOUNITS'
19222 !      include 'COMMON.SETUP'
19223 !      include 'COMMON.MD'
19224 !     Local variables
19225       real(kind=8) :: emin
19226       integer :: i,j,imin,ierr
19227       integer :: diff,allnss,newnss
19228       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19229                 newihpb,newjhpb
19230       logical :: found
19231       integer,dimension(0:nfgtasks) :: i_newnss
19232       integer,dimension(0:nfgtasks) :: displ
19233       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19234       integer :: g_newnss
19235
19236       allnss=0
19237       do i=1,nres-1
19238         do j=i+1,nres
19239           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19240             allnss=allnss+1
19241             allflag(allnss)=0
19242             allihpb(allnss)=i
19243             alljhpb(allnss)=j
19244           endif
19245         enddo
19246       enddo
19247
19248 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19249
19250  1    emin=1.0d300
19251       do i=1,allnss
19252         if (allflag(i).eq.0 .and. &
19253              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19254           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19255           imin=i
19256         endif
19257       enddo
19258       if (emin.lt.1.0d300) then
19259         allflag(imin)=1
19260         do i=1,allnss
19261           if (allflag(i).eq.0 .and. &
19262                (allihpb(i).eq.allihpb(imin) .or. &
19263                alljhpb(i).eq.allihpb(imin) .or. &
19264                allihpb(i).eq.alljhpb(imin) .or. &
19265                alljhpb(i).eq.alljhpb(imin))) then
19266             allflag(i)=-1
19267           endif
19268         enddo
19269         goto 1
19270       endif
19271
19272 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19273
19274       newnss=0
19275       do i=1,allnss
19276         if (allflag(i).eq.1) then
19277           newnss=newnss+1
19278           newihpb(newnss)=allihpb(i)
19279           newjhpb(newnss)=alljhpb(i)
19280         endif
19281       enddo
19282
19283 #ifdef MPI
19284       if (nfgtasks.gt.1)then
19285
19286         call MPI_Reduce(newnss,g_newnss,1,&
19287           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19288         call MPI_Gather(newnss,1,MPI_INTEGER,&
19289                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19290         displ(0)=0
19291         do i=1,nfgtasks-1,1
19292           displ(i)=i_newnss(i-1)+displ(i-1)
19293         enddo
19294         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19295                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19296                          king,FG_COMM,IERR)
19297         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19298                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19299                          king,FG_COMM,IERR)
19300         if(fg_rank.eq.0) then
19301 !         print *,'g_newnss',g_newnss
19302 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19303 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19304          newnss=g_newnss
19305          do i=1,newnss
19306           newihpb(i)=g_newihpb(i)
19307           newjhpb(i)=g_newjhpb(i)
19308          enddo
19309         endif
19310       endif
19311 #endif
19312
19313       diff=newnss-nss
19314
19315 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19316 !       print *,newnss,nss,maxdim
19317       do i=1,nss
19318         found=.false.
19319 !        print *,newnss
19320         do j=1,newnss
19321 !!          print *,j
19322           if (idssb(i).eq.newihpb(j) .and. &
19323                jdssb(i).eq.newjhpb(j)) found=.true.
19324         enddo
19325 #ifndef CLUST
19326 #ifndef WHAM
19327 !        write(iout,*) "found",found,i,j
19328         if (.not.found.and.fg_rank.eq.0) &
19329             write(iout,'(a15,f12.2,f8.1,2i5)') &
19330              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19331 #endif
19332 #endif
19333       enddo
19334
19335       do i=1,newnss
19336         found=.false.
19337         do j=1,nss
19338 !          print *,i,j
19339           if (newihpb(i).eq.idssb(j) .and. &
19340                newjhpb(i).eq.jdssb(j)) found=.true.
19341         enddo
19342 #ifndef CLUST
19343 #ifndef WHAM
19344 !        write(iout,*) "found",found,i,j
19345         if (.not.found.and.fg_rank.eq.0) &
19346             write(iout,'(a15,f12.2,f8.1,2i5)') &
19347              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19348 #endif
19349 #endif
19350       enddo
19351
19352       nss=newnss
19353       do i=1,nss
19354         idssb(i)=newihpb(i)
19355         jdssb(i)=newjhpb(i)
19356       enddo
19357
19358       return
19359       end subroutine dyn_set_nss
19360 ! Lipid transfer energy function
19361       subroutine Eliptransfer(eliptran)
19362 !C this is done by Adasko
19363 !C      print *,"wchodze"
19364 !C structure of box:
19365 !C      water
19366 !C--bordliptop-- buffore starts
19367 !C--bufliptop--- here true lipid starts
19368 !C      lipid
19369 !C--buflipbot--- lipid ends buffore starts
19370 !C--bordlipbot--buffore ends
19371       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19372       integer :: i
19373       eliptran=0.0
19374 !      print *, "I am in eliptran"
19375       do i=ilip_start,ilip_end
19376 !C       do i=1,1
19377         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19378          cycle
19379
19380         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19381         if (positi.le.0.0) positi=positi+boxzsize
19382 !C        print *,i
19383 !C first for peptide groups
19384 !c for each residue check if it is in lipid or lipid water border area
19385        if ((positi.gt.bordlipbot)  &
19386       .and.(positi.lt.bordliptop)) then
19387 !C the energy transfer exist
19388         if (positi.lt.buflipbot) then
19389 !C what fraction I am in
19390          fracinbuf=1.0d0-      &
19391              ((positi-bordlipbot)/lipbufthick)
19392 !C lipbufthick is thickenes of lipid buffore
19393          sslip=sscalelip(fracinbuf)
19394          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19395          eliptran=eliptran+sslip*pepliptran
19396          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19397          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19398 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19399
19400 !C        print *,"doing sccale for lower part"
19401 !C         print *,i,sslip,fracinbuf,ssgradlip
19402         elseif (positi.gt.bufliptop) then
19403          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19404          sslip=sscalelip(fracinbuf)
19405          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19406          eliptran=eliptran+sslip*pepliptran
19407          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19408          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19409 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19410 !C          print *, "doing sscalefor top part"
19411 !C         print *,i,sslip,fracinbuf,ssgradlip
19412         else
19413          eliptran=eliptran+pepliptran
19414 !C         print *,"I am in true lipid"
19415         endif
19416 !C       else
19417 !C       eliptran=elpitran+0.0 ! I am in water
19418        endif
19419        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19420        enddo
19421 ! here starts the side chain transfer
19422        do i=ilip_start,ilip_end
19423         if (itype(i,1).eq.ntyp1) cycle
19424         positi=(mod(c(3,i+nres),boxzsize))
19425         if (positi.le.0) positi=positi+boxzsize
19426 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19427 !c for each residue check if it is in lipid or lipid water border area
19428 !C       respos=mod(c(3,i+nres),boxzsize)
19429 !C       print *,positi,bordlipbot,buflipbot
19430        if ((positi.gt.bordlipbot) &
19431        .and.(positi.lt.bordliptop)) then
19432 !C the energy transfer exist
19433         if (positi.lt.buflipbot) then
19434          fracinbuf=1.0d0-   &
19435            ((positi-bordlipbot)/lipbufthick)
19436 !C lipbufthick is thickenes of lipid buffore
19437          sslip=sscalelip(fracinbuf)
19438          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19439          eliptran=eliptran+sslip*liptranene(itype(i,1))
19440          gliptranx(3,i)=gliptranx(3,i) &
19441       +ssgradlip*liptranene(itype(i,1))
19442          gliptranc(3,i-1)= gliptranc(3,i-1) &
19443       +ssgradlip*liptranene(itype(i,1))
19444 !C         print *,"doing sccale for lower part"
19445         elseif (positi.gt.bufliptop) then
19446          fracinbuf=1.0d0-  &
19447       ((bordliptop-positi)/lipbufthick)
19448          sslip=sscalelip(fracinbuf)
19449          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19450          eliptran=eliptran+sslip*liptranene(itype(i,1))
19451          gliptranx(3,i)=gliptranx(3,i)  &
19452        +ssgradlip*liptranene(itype(i,1))
19453          gliptranc(3,i-1)= gliptranc(3,i-1) &
19454       +ssgradlip*liptranene(itype(i,1))
19455 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19456         else
19457          eliptran=eliptran+liptranene(itype(i,1))
19458 !C         print *,"I am in true lipid"
19459         endif
19460         endif ! if in lipid or buffor
19461 !C       else
19462 !C       eliptran=elpitran+0.0 ! I am in water
19463         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19464        enddo
19465        return
19466        end  subroutine Eliptransfer
19467 !----------------------------------NANO FUNCTIONS
19468 !C-----------------------------------------------------------------------
19469 !C-----------------------------------------------------------
19470 !C This subroutine is to mimic the histone like structure but as well can be
19471 !C utilizet to nanostructures (infinit) small modification has to be used to
19472 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19473 !C gradient has to be modified at the ends
19474 !C The energy function is Kihara potential
19475 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19476 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19477 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19478 !C simple Kihara potential
19479       subroutine calctube(Etube)
19480       real(kind=8),dimension(3) :: vectube
19481       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19482        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19483        sc_aa_tube,sc_bb_tube
19484       integer :: i,j,iti
19485       Etube=0.0d0
19486       do i=itube_start,itube_end
19487         enetube(i)=0.0d0
19488         enetube(i+nres)=0.0d0
19489       enddo
19490 !C first we calculate the distance from tube center
19491 !C for UNRES
19492        do i=itube_start,itube_end
19493 !C lets ommit dummy atoms for now
19494        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19495 !C now calculate distance from center of tube and direction vectors
19496       xmin=boxxsize
19497       ymin=boxysize
19498 ! Find minimum distance in periodic box
19499         do j=-1,1
19500          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19501          vectube(1)=vectube(1)+boxxsize*j
19502          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19503          vectube(2)=vectube(2)+boxysize*j
19504          xminact=abs(vectube(1)-tubecenter(1))
19505          yminact=abs(vectube(2)-tubecenter(2))
19506            if (xmin.gt.xminact) then
19507             xmin=xminact
19508             xtemp=vectube(1)
19509            endif
19510            if (ymin.gt.yminact) then
19511              ymin=yminact
19512              ytemp=vectube(2)
19513             endif
19514          enddo
19515       vectube(1)=xtemp
19516       vectube(2)=ytemp
19517       vectube(1)=vectube(1)-tubecenter(1)
19518       vectube(2)=vectube(2)-tubecenter(2)
19519
19520 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19521 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19522
19523 !C as the tube is infinity we do not calculate the Z-vector use of Z
19524 !C as chosen axis
19525       vectube(3)=0.0d0
19526 !C now calculte the distance
19527        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19528 !C now normalize vector
19529       vectube(1)=vectube(1)/tub_r
19530       vectube(2)=vectube(2)/tub_r
19531 !C calculte rdiffrence between r and r0
19532       rdiff=tub_r-tubeR0
19533 !C and its 6 power
19534       rdiff6=rdiff**6.0d0
19535 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19536        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19537 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19538 !C       print *,rdiff,rdiff6,pep_aa_tube
19539 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19540 !C now we calculate gradient
19541        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19542             6.0d0*pep_bb_tube)/rdiff6/rdiff
19543 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19544 !C     &rdiff,fac
19545 !C now direction of gg_tube vector
19546         do j=1,3
19547         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19548         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19549         enddo
19550         enddo
19551 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19552 !C        print *,gg_tube(1,0),"TU"
19553
19554
19555        do i=itube_start,itube_end
19556 !C Lets not jump over memory as we use many times iti
19557          iti=itype(i,1)
19558 !C lets ommit dummy atoms for now
19559          if ((iti.eq.ntyp1)  &
19560 !C in UNRES uncomment the line below as GLY has no side-chain...
19561 !C      .or.(iti.eq.10)
19562         ) cycle
19563       xmin=boxxsize
19564       ymin=boxysize
19565         do j=-1,1
19566          vectube(1)=mod((c(1,i+nres)),boxxsize)
19567          vectube(1)=vectube(1)+boxxsize*j
19568          vectube(2)=mod((c(2,i+nres)),boxysize)
19569          vectube(2)=vectube(2)+boxysize*j
19570
19571          xminact=abs(vectube(1)-tubecenter(1))
19572          yminact=abs(vectube(2)-tubecenter(2))
19573            if (xmin.gt.xminact) then
19574             xmin=xminact
19575             xtemp=vectube(1)
19576            endif
19577            if (ymin.gt.yminact) then
19578              ymin=yminact
19579              ytemp=vectube(2)
19580             endif
19581          enddo
19582       vectube(1)=xtemp
19583       vectube(2)=ytemp
19584 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19585 !C     &     tubecenter(2)
19586       vectube(1)=vectube(1)-tubecenter(1)
19587       vectube(2)=vectube(2)-tubecenter(2)
19588
19589 !C as the tube is infinity we do not calculate the Z-vector use of Z
19590 !C as chosen axis
19591       vectube(3)=0.0d0
19592 !C now calculte the distance
19593        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19594 !C now normalize vector
19595       vectube(1)=vectube(1)/tub_r
19596       vectube(2)=vectube(2)/tub_r
19597
19598 !C calculte rdiffrence between r and r0
19599       rdiff=tub_r-tubeR0
19600 !C and its 6 power
19601       rdiff6=rdiff**6.0d0
19602 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19603        sc_aa_tube=sc_aa_tube_par(iti)
19604        sc_bb_tube=sc_bb_tube_par(iti)
19605        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19606        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19607              6.0d0*sc_bb_tube/rdiff6/rdiff
19608 !C now direction of gg_tube vector
19609          do j=1,3
19610           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19611           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19612          enddo
19613         enddo
19614         do i=itube_start,itube_end
19615           Etube=Etube+enetube(i)+enetube(i+nres)
19616         enddo
19617 !C        print *,"ETUBE", etube
19618         return
19619         end subroutine calctube
19620 !C TO DO 1) add to total energy
19621 !C       2) add to gradient summation
19622 !C       3) add reading parameters (AND of course oppening of PARAM file)
19623 !C       4) add reading the center of tube
19624 !C       5) add COMMONs
19625 !C       6) add to zerograd
19626 !C       7) allocate matrices
19627
19628
19629 !C-----------------------------------------------------------------------
19630 !C-----------------------------------------------------------
19631 !C This subroutine is to mimic the histone like structure but as well can be
19632 !C utilizet to nanostructures (infinit) small modification has to be used to
19633 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19634 !C gradient has to be modified at the ends
19635 !C The energy function is Kihara potential
19636 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19637 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19638 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19639 !C simple Kihara potential
19640       subroutine calctube2(Etube)
19641             real(kind=8),dimension(3) :: vectube
19642       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19643        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19644        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19645       integer:: i,j,iti
19646       Etube=0.0d0
19647       do i=itube_start,itube_end
19648         enetube(i)=0.0d0
19649         enetube(i+nres)=0.0d0
19650       enddo
19651 !C first we calculate the distance from tube center
19652 !C first sugare-phosphate group for NARES this would be peptide group
19653 !C for UNRES
19654        do i=itube_start,itube_end
19655 !C lets ommit dummy atoms for now
19656
19657        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19658 !C now calculate distance from center of tube and direction vectors
19659 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19660 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19661 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19662 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19663       xmin=boxxsize
19664       ymin=boxysize
19665         do j=-1,1
19666          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19667          vectube(1)=vectube(1)+boxxsize*j
19668          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19669          vectube(2)=vectube(2)+boxysize*j
19670
19671          xminact=abs(vectube(1)-tubecenter(1))
19672          yminact=abs(vectube(2)-tubecenter(2))
19673            if (xmin.gt.xminact) then
19674             xmin=xminact
19675             xtemp=vectube(1)
19676            endif
19677            if (ymin.gt.yminact) then
19678              ymin=yminact
19679              ytemp=vectube(2)
19680             endif
19681          enddo
19682       vectube(1)=xtemp
19683       vectube(2)=ytemp
19684       vectube(1)=vectube(1)-tubecenter(1)
19685       vectube(2)=vectube(2)-tubecenter(2)
19686
19687 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19688 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19689
19690 !C as the tube is infinity we do not calculate the Z-vector use of Z
19691 !C as chosen axis
19692       vectube(3)=0.0d0
19693 !C now calculte the distance
19694        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19695 !C now normalize vector
19696       vectube(1)=vectube(1)/tub_r
19697       vectube(2)=vectube(2)/tub_r
19698 !C calculte rdiffrence between r and r0
19699       rdiff=tub_r-tubeR0
19700 !C and its 6 power
19701       rdiff6=rdiff**6.0d0
19702 !C THIS FRAGMENT MAKES TUBE FINITE
19703         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19704         if (positi.le.0) positi=positi+boxzsize
19705 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19706 !c for each residue check if it is in lipid or lipid water border area
19707 !C       respos=mod(c(3,i+nres),boxzsize)
19708 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19709        if ((positi.gt.bordtubebot)  &
19710         .and.(positi.lt.bordtubetop)) then
19711 !C the energy transfer exist
19712         if (positi.lt.buftubebot) then
19713          fracinbuf=1.0d0-  &
19714            ((positi-bordtubebot)/tubebufthick)
19715 !C lipbufthick is thickenes of lipid buffore
19716          sstube=sscalelip(fracinbuf)
19717          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19718 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19719          enetube(i)=enetube(i)+sstube*tubetranenepep
19720 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19721 !C     &+ssgradtube*tubetranene(itype(i,1))
19722 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19723 !C     &+ssgradtube*tubetranene(itype(i,1))
19724 !C         print *,"doing sccale for lower part"
19725         elseif (positi.gt.buftubetop) then
19726          fracinbuf=1.0d0-  &
19727         ((bordtubetop-positi)/tubebufthick)
19728          sstube=sscalelip(fracinbuf)
19729          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19730          enetube(i)=enetube(i)+sstube*tubetranenepep
19731 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19732 !C     &+ssgradtube*tubetranene(itype(i,1))
19733 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19734 !C     &+ssgradtube*tubetranene(itype(i,1))
19735 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19736         else
19737          sstube=1.0d0
19738          ssgradtube=0.0d0
19739          enetube(i)=enetube(i)+sstube*tubetranenepep
19740 !C         print *,"I am in true lipid"
19741         endif
19742         else
19743 !C          sstube=0.0d0
19744 !C          ssgradtube=0.0d0
19745         cycle
19746         endif ! if in lipid or buffor
19747
19748 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19749        enetube(i)=enetube(i)+sstube* &
19750         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19751 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19752 !C       print *,rdiff,rdiff6,pep_aa_tube
19753 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19754 !C now we calculate gradient
19755        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19756              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19757 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19758 !C     &rdiff,fac
19759
19760 !C now direction of gg_tube vector
19761        do j=1,3
19762         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19763         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19764         enddo
19765          gg_tube(3,i)=gg_tube(3,i)  &
19766        +ssgradtube*enetube(i)/sstube/2.0d0
19767          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19768        +ssgradtube*enetube(i)/sstube/2.0d0
19769
19770         enddo
19771 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19772 !C        print *,gg_tube(1,0),"TU"
19773         do i=itube_start,itube_end
19774 !C Lets not jump over memory as we use many times iti
19775          iti=itype(i,1)
19776 !C lets ommit dummy atoms for now
19777          if ((iti.eq.ntyp1) &
19778 !!C in UNRES uncomment the line below as GLY has no side-chain...
19779            .or.(iti.eq.10) &
19780           ) cycle
19781           vectube(1)=c(1,i+nres)
19782           vectube(1)=mod(vectube(1),boxxsize)
19783           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19784           vectube(2)=c(2,i+nres)
19785           vectube(2)=mod(vectube(2),boxysize)
19786           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19787
19788       vectube(1)=vectube(1)-tubecenter(1)
19789       vectube(2)=vectube(2)-tubecenter(2)
19790 !C THIS FRAGMENT MAKES TUBE FINITE
19791         positi=(mod(c(3,i+nres),boxzsize))
19792         if (positi.le.0) positi=positi+boxzsize
19793 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19794 !c for each residue check if it is in lipid or lipid water border area
19795 !C       respos=mod(c(3,i+nres),boxzsize)
19796 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19797
19798        if ((positi.gt.bordtubebot)  &
19799         .and.(positi.lt.bordtubetop)) then
19800 !C the energy transfer exist
19801         if (positi.lt.buftubebot) then
19802          fracinbuf=1.0d0- &
19803             ((positi-bordtubebot)/tubebufthick)
19804 !C lipbufthick is thickenes of lipid buffore
19805          sstube=sscalelip(fracinbuf)
19806          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19807 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19808          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19809 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19810 !C     &+ssgradtube*tubetranene(itype(i,1))
19811 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19812 !C     &+ssgradtube*tubetranene(itype(i,1))
19813 !C         print *,"doing sccale for lower part"
19814         elseif (positi.gt.buftubetop) then
19815          fracinbuf=1.0d0- &
19816         ((bordtubetop-positi)/tubebufthick)
19817
19818          sstube=sscalelip(fracinbuf)
19819          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19820          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19821 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19822 !C     &+ssgradtube*tubetranene(itype(i,1))
19823 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19824 !C     &+ssgradtube*tubetranene(itype(i,1))
19825 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19826         else
19827          sstube=1.0d0
19828          ssgradtube=0.0d0
19829          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19830 !C         print *,"I am in true lipid"
19831         endif
19832         else
19833 !C          sstube=0.0d0
19834 !C          ssgradtube=0.0d0
19835         cycle
19836         endif ! if in lipid or buffor
19837 !CEND OF FINITE FRAGMENT
19838 !C as the tube is infinity we do not calculate the Z-vector use of Z
19839 !C as chosen axis
19840       vectube(3)=0.0d0
19841 !C now calculte the distance
19842        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19843 !C now normalize vector
19844       vectube(1)=vectube(1)/tub_r
19845       vectube(2)=vectube(2)/tub_r
19846 !C calculte rdiffrence between r and r0
19847       rdiff=tub_r-tubeR0
19848 !C and its 6 power
19849       rdiff6=rdiff**6.0d0
19850 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19851        sc_aa_tube=sc_aa_tube_par(iti)
19852        sc_bb_tube=sc_bb_tube_par(iti)
19853        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19854                        *sstube+enetube(i+nres)
19855 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19856 !C now we calculate gradient
19857        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19858             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19859 !C now direction of gg_tube vector
19860          do j=1,3
19861           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19862           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19863          enddo
19864          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19865        +ssgradtube*enetube(i+nres)/sstube
19866          gg_tube(3,i-1)= gg_tube(3,i-1) &
19867        +ssgradtube*enetube(i+nres)/sstube
19868
19869         enddo
19870         do i=itube_start,itube_end
19871           Etube=Etube+enetube(i)+enetube(i+nres)
19872         enddo
19873 !C        print *,"ETUBE", etube
19874         return
19875         end subroutine calctube2
19876 !=====================================================================================================================================
19877       subroutine calcnano(Etube)
19878       real(kind=8),dimension(3) :: vectube
19879
19880       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19881        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19882        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19883        integer:: i,j,iti,r
19884
19885       Etube=0.0d0
19886 !      print *,itube_start,itube_end,"poczatek"
19887       do i=itube_start,itube_end
19888         enetube(i)=0.0d0
19889         enetube(i+nres)=0.0d0
19890       enddo
19891 !C first we calculate the distance from tube center
19892 !C first sugare-phosphate group for NARES this would be peptide group
19893 !C for UNRES
19894        do i=itube_start,itube_end
19895 !C lets ommit dummy atoms for now
19896        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19897 !C now calculate distance from center of tube and direction vectors
19898       xmin=boxxsize
19899       ymin=boxysize
19900       zmin=boxzsize
19901
19902         do j=-1,1
19903          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19904          vectube(1)=vectube(1)+boxxsize*j
19905          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19906          vectube(2)=vectube(2)+boxysize*j
19907          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19908          vectube(3)=vectube(3)+boxzsize*j
19909
19910
19911          xminact=dabs(vectube(1)-tubecenter(1))
19912          yminact=dabs(vectube(2)-tubecenter(2))
19913          zminact=dabs(vectube(3)-tubecenter(3))
19914
19915            if (xmin.gt.xminact) then
19916             xmin=xminact
19917             xtemp=vectube(1)
19918            endif
19919            if (ymin.gt.yminact) then
19920              ymin=yminact
19921              ytemp=vectube(2)
19922             endif
19923            if (zmin.gt.zminact) then
19924              zmin=zminact
19925              ztemp=vectube(3)
19926             endif
19927          enddo
19928       vectube(1)=xtemp
19929       vectube(2)=ytemp
19930       vectube(3)=ztemp
19931
19932       vectube(1)=vectube(1)-tubecenter(1)
19933       vectube(2)=vectube(2)-tubecenter(2)
19934       vectube(3)=vectube(3)-tubecenter(3)
19935
19936 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19937 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19938 !C as the tube is infinity we do not calculate the Z-vector use of Z
19939 !C as chosen axis
19940 !C      vectube(3)=0.0d0
19941 !C now calculte the distance
19942        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19943 !C now normalize vector
19944       vectube(1)=vectube(1)/tub_r
19945       vectube(2)=vectube(2)/tub_r
19946       vectube(3)=vectube(3)/tub_r
19947 !C calculte rdiffrence between r and r0
19948       rdiff=tub_r-tubeR0
19949 !C and its 6 power
19950       rdiff6=rdiff**6.0d0
19951 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19952        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19953 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19954 !C       print *,rdiff,rdiff6,pep_aa_tube
19955 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19956 !C now we calculate gradient
19957        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19958             6.0d0*pep_bb_tube)/rdiff6/rdiff
19959 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19960 !C     &rdiff,fac
19961          if (acavtubpep.eq.0.0d0) then
19962 !C go to 667
19963          enecavtube(i)=0.0
19964          faccav=0.0
19965          else
19966          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19967          enecavtube(i)=  &
19968         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19969         /denominator
19970          enecavtube(i)=0.0
19971          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19972         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19973         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19974         /denominator**2.0d0
19975 !C         faccav=0.0
19976 !C         fac=fac+faccav
19977 !C 667     continue
19978          endif
19979           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19980         do j=1,3
19981         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19982         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19983         enddo
19984         enddo
19985
19986        do i=itube_start,itube_end
19987         enecavtube(i)=0.0d0
19988 !C Lets not jump over memory as we use many times iti
19989          iti=itype(i,1)
19990 !C lets ommit dummy atoms for now
19991          if ((iti.eq.ntyp1) &
19992 !C in UNRES uncomment the line below as GLY has no side-chain...
19993 !C      .or.(iti.eq.10)
19994          ) cycle
19995       xmin=boxxsize
19996       ymin=boxysize
19997       zmin=boxzsize
19998         do j=-1,1
19999          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20000          vectube(1)=vectube(1)+boxxsize*j
20001          vectube(2)=dmod((c(2,i+nres)),boxysize)
20002          vectube(2)=vectube(2)+boxysize*j
20003          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20004          vectube(3)=vectube(3)+boxzsize*j
20005
20006
20007          xminact=dabs(vectube(1)-tubecenter(1))
20008          yminact=dabs(vectube(2)-tubecenter(2))
20009          zminact=dabs(vectube(3)-tubecenter(3))
20010
20011            if (xmin.gt.xminact) then
20012             xmin=xminact
20013             xtemp=vectube(1)
20014            endif
20015            if (ymin.gt.yminact) then
20016              ymin=yminact
20017              ytemp=vectube(2)
20018             endif
20019            if (zmin.gt.zminact) then
20020              zmin=zminact
20021              ztemp=vectube(3)
20022             endif
20023          enddo
20024       vectube(1)=xtemp
20025       vectube(2)=ytemp
20026       vectube(3)=ztemp
20027
20028 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20029 !C     &     tubecenter(2)
20030       vectube(1)=vectube(1)-tubecenter(1)
20031       vectube(2)=vectube(2)-tubecenter(2)
20032       vectube(3)=vectube(3)-tubecenter(3)
20033 !C now calculte the distance
20034        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20035 !C now normalize vector
20036       vectube(1)=vectube(1)/tub_r
20037       vectube(2)=vectube(2)/tub_r
20038       vectube(3)=vectube(3)/tub_r
20039
20040 !C calculte rdiffrence between r and r0
20041       rdiff=tub_r-tubeR0
20042 !C and its 6 power
20043       rdiff6=rdiff**6.0d0
20044        sc_aa_tube=sc_aa_tube_par(iti)
20045        sc_bb_tube=sc_bb_tube_par(iti)
20046        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20047 !C       enetube(i+nres)=0.0d0
20048 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20049 !C now we calculate gradient
20050        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20051             6.0d0*sc_bb_tube/rdiff6/rdiff
20052 !C       fac=0.0
20053 !C now direction of gg_tube vector
20054 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20055          if (acavtub(iti).eq.0.0d0) then
20056 !C go to 667
20057          enecavtube(i+nres)=0.0d0
20058          faccav=0.0d0
20059          else
20060          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20061          enecavtube(i+nres)=   &
20062         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20063         /denominator
20064 !C         enecavtube(i)=0.0
20065          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20066         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20067         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20068         /denominator**2.0d0
20069 !C         faccav=0.0
20070          fac=fac+faccav
20071 !C 667     continue
20072          endif
20073 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20074 !C     &   enecavtube(i),faccav
20075 !C         print *,"licz=",
20076 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20077 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20078          do j=1,3
20079           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20080           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20081          enddo
20082           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20083         enddo
20084
20085
20086
20087         do i=itube_start,itube_end
20088           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20089          +enecavtube(i+nres)
20090         enddo
20091 !        do i=1,20
20092 !         print *,"begin", i,"a"
20093 !         do r=1,10000
20094 !          rdiff=r/100.0d0
20095 !          rdiff6=rdiff**6.0d0
20096 !          sc_aa_tube=sc_aa_tube_par(i)
20097 !          sc_bb_tube=sc_bb_tube_par(i)
20098 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20099 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20100 !          enecavtube(i)=   &
20101 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20102 !         /denominator
20103
20104 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20105 !         enddo
20106 !         print *,"end",i,"a"
20107 !        enddo
20108 !C        print *,"ETUBE", etube
20109         return
20110         end subroutine calcnano
20111
20112 !===============================================
20113 !--------------------------------------------------------------------------------
20114 !C first for shielding is setting of function of side-chains
20115
20116        subroutine set_shield_fac2
20117        real(kind=8) :: div77_81=0.974996043d0, &
20118         div4_81=0.2222222222d0
20119        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20120          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20121          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20122          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20123 !C the vector between center of side_chain and peptide group
20124        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20125          pept_group,costhet_grad,cosphi_grad_long, &
20126          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20127          sh_frac_dist_grad,pep_side
20128         integer i,j,k
20129 !C      write(2,*) "ivec",ivec_start,ivec_end
20130       do i=1,nres
20131         fac_shield(i)=0.0d0
20132         ishield_list(i)=0
20133         do j=1,3
20134         grad_shield(j,i)=0.0d0
20135         enddo
20136       enddo
20137       do i=ivec_start,ivec_end
20138 !C      do i=1,nres-1
20139 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20140 !      ishield_list(i)=0
20141       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20142 !Cif there two consequtive dummy atoms there is no peptide group between them
20143 !C the line below has to be changed for FGPROC>1
20144       VolumeTotal=0.0
20145       do k=1,nres
20146        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20147        dist_pep_side=0.0
20148        dist_side_calf=0.0
20149        do j=1,3
20150 !C first lets set vector conecting the ithe side-chain with kth side-chain
20151       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20152 !C      pep_side(j)=2.0d0
20153 !C and vector conecting the side-chain with its proper calfa
20154       side_calf(j)=c(j,k+nres)-c(j,k)
20155 !C      side_calf(j)=2.0d0
20156       pept_group(j)=c(j,i)-c(j,i+1)
20157 !C lets have their lenght
20158       dist_pep_side=pep_side(j)**2+dist_pep_side
20159       dist_side_calf=dist_side_calf+side_calf(j)**2
20160       dist_pept_group=dist_pept_group+pept_group(j)**2
20161       enddo
20162        dist_pep_side=sqrt(dist_pep_side)
20163        dist_pept_group=sqrt(dist_pept_group)
20164        dist_side_calf=sqrt(dist_side_calf)
20165       do j=1,3
20166         pep_side_norm(j)=pep_side(j)/dist_pep_side
20167         side_calf_norm(j)=dist_side_calf
20168       enddo
20169 !C now sscale fraction
20170        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20171 !       print *,buff_shield,"buff",sh_frac_dist
20172 !C now sscale
20173         if (sh_frac_dist.le.0.0) cycle
20174 !C        print *,ishield_list(i),i
20175 !C If we reach here it means that this side chain reaches the shielding sphere
20176 !C Lets add him to the list for gradient
20177         ishield_list(i)=ishield_list(i)+1
20178 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20179 !C this list is essential otherwise problem would be O3
20180         shield_list(ishield_list(i),i)=k
20181 !C Lets have the sscale value
20182         if (sh_frac_dist.gt.1.0) then
20183          scale_fac_dist=1.0d0
20184          do j=1,3
20185          sh_frac_dist_grad(j)=0.0d0
20186          enddo
20187         else
20188          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20189                         *(2.0d0*sh_frac_dist-3.0d0)
20190          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20191                        /dist_pep_side/buff_shield*0.5d0
20192          do j=1,3
20193          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20194 !C         sh_frac_dist_grad(j)=0.0d0
20195 !C         scale_fac_dist=1.0d0
20196 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20197 !C     &                    sh_frac_dist_grad(j)
20198          enddo
20199         endif
20200 !C this is what is now we have the distance scaling now volume...
20201       short=short_r_sidechain(itype(k,1))
20202       long=long_r_sidechain(itype(k,1))
20203       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20204       sinthet=short/dist_pep_side*costhet
20205 !      print *,"SORT",short,long,sinthet,costhet
20206 !C now costhet_grad
20207 !C       costhet=0.6d0
20208 !C       sinthet=0.8
20209        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20210 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20211 !C     &             -short/dist_pep_side**2/costhet)
20212 !C       costhet_fac=0.0d0
20213        do j=1,3
20214          costhet_grad(j)=costhet_fac*pep_side(j)
20215        enddo
20216 !C remember for the final gradient multiply costhet_grad(j)
20217 !C for side_chain by factor -2 !
20218 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20219 !C pep_side0pept_group is vector multiplication
20220       pep_side0pept_group=0.0d0
20221       do j=1,3
20222       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20223       enddo
20224       cosalfa=(pep_side0pept_group/ &
20225       (dist_pep_side*dist_side_calf))
20226       fac_alfa_sin=1.0d0-cosalfa**2
20227       fac_alfa_sin=dsqrt(fac_alfa_sin)
20228       rkprim=fac_alfa_sin*(long-short)+short
20229 !C      rkprim=short
20230
20231 !C now costhet_grad
20232        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20233 !C       cosphi=0.6
20234        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20235        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20236            dist_pep_side**2)
20237 !C       sinphi=0.8
20238        do j=1,3
20239          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20240       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20241       *(long-short)/fac_alfa_sin*cosalfa/ &
20242       ((dist_pep_side*dist_side_calf))* &
20243       ((side_calf(j))-cosalfa* &
20244       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20245 !C       cosphi_grad_long(j)=0.0d0
20246         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20247       *(long-short)/fac_alfa_sin*cosalfa &
20248       /((dist_pep_side*dist_side_calf))* &
20249       (pep_side(j)- &
20250       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20251 !C       cosphi_grad_loc(j)=0.0d0
20252        enddo
20253 !C      print *,sinphi,sinthet
20254       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20255                          /VSolvSphere_div
20256 !C     &                    *wshield
20257 !C now the gradient...
20258       do j=1,3
20259       grad_shield(j,i)=grad_shield(j,i) &
20260 !C gradient po skalowaniu
20261                      +(sh_frac_dist_grad(j)*VofOverlap &
20262 !C  gradient po costhet
20263             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20264         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20265             sinphi/sinthet*costhet*costhet_grad(j) &
20266            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20267         )*wshield
20268 !C grad_shield_side is Cbeta sidechain gradient
20269       grad_shield_side(j,ishield_list(i),i)=&
20270              (sh_frac_dist_grad(j)*-2.0d0&
20271              *VofOverlap&
20272             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20273        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20274             sinphi/sinthet*costhet*costhet_grad(j)&
20275            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20276             )*wshield
20277 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20278 !            sinphi/sinthet,&
20279 !           +sinthet/sinphi,"HERE"
20280        grad_shield_loc(j,ishield_list(i),i)=   &
20281             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20282       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20283             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20284              ))&
20285              *wshield
20286 !         print *,grad_shield_loc(j,ishield_list(i),i)
20287       enddo
20288       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20289       enddo
20290       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20291
20292 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20293       enddo
20294       return
20295       end subroutine set_shield_fac2
20296 !----------------------------------------------------------------------------
20297 ! SOUBROUTINE FOR AFM
20298        subroutine AFMvel(Eafmforce)
20299        use MD_data, only:totTafm
20300       real(kind=8),dimension(3) :: diffafm
20301       real(kind=8) :: afmdist,Eafmforce
20302        integer :: i
20303 !C Only for check grad COMMENT if not used for checkgrad
20304 !C      totT=3.0d0
20305 !C--------------------------------------------------------
20306 !C      print *,"wchodze"
20307       afmdist=0.0d0
20308       Eafmforce=0.0d0
20309       do i=1,3
20310       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20311       afmdist=afmdist+diffafm(i)**2
20312       enddo
20313       afmdist=dsqrt(afmdist)
20314 !      totTafm=3.0
20315       Eafmforce=0.5d0*forceAFMconst &
20316       *(distafminit+totTafm*velAFMconst-afmdist)**2
20317 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20318       do i=1,3
20319       gradafm(i,afmend-1)=-forceAFMconst* &
20320        (distafminit+totTafm*velAFMconst-afmdist) &
20321        *diffafm(i)/afmdist
20322       gradafm(i,afmbeg-1)=forceAFMconst* &
20323       (distafminit+totTafm*velAFMconst-afmdist) &
20324       *diffafm(i)/afmdist
20325       enddo
20326 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20327       return
20328       end subroutine AFMvel
20329 !---------------------------------------------------------
20330        subroutine AFMforce(Eafmforce)
20331
20332       real(kind=8),dimension(3) :: diffafm
20333 !      real(kind=8) ::afmdist
20334       real(kind=8) :: afmdist,Eafmforce
20335       integer :: i
20336       afmdist=0.0d0
20337       Eafmforce=0.0d0
20338       do i=1,3
20339       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20340       afmdist=afmdist+diffafm(i)**2
20341       enddo
20342       afmdist=dsqrt(afmdist)
20343 !      print *,afmdist,distafminit
20344       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20345       do i=1,3
20346       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20347       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20348       enddo
20349 !C      print *,'AFM',Eafmforce
20350       return
20351       end subroutine AFMforce
20352
20353 !-----------------------------------------------------------------------------
20354 #ifdef WHAM
20355       subroutine read_ssHist
20356 !      implicit none
20357 !      Includes
20358 !      include 'DIMENSIONS'
20359 !      include "DIMENSIONS.FREE"
20360 !      include 'COMMON.FREE'
20361 !     Local variables
20362       integer :: i,j
20363       character(len=80) :: controlcard
20364
20365       do i=1,dyn_nssHist
20366         call card_concat(controlcard,.true.)
20367         read(controlcard,*) &
20368              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20369       enddo
20370
20371       return
20372       end subroutine read_ssHist
20373 #endif
20374 !-----------------------------------------------------------------------------
20375       integer function indmat(i,j)
20376 !el
20377 ! get the position of the jth ijth fragment of the chain coordinate system
20378 ! in the fromto array.
20379         integer :: i,j
20380
20381         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20382       return
20383       end function indmat
20384 !-----------------------------------------------------------------------------
20385       real(kind=8) function sigm(x)
20386 !el
20387        real(kind=8) :: x
20388         sigm=0.25d0*x
20389       return
20390       end function sigm
20391 !-----------------------------------------------------------------------------
20392 !-----------------------------------------------------------------------------
20393       subroutine alloc_ener_arrays
20394 !EL Allocation of arrays used by module energy
20395       use MD_data, only: mset
20396 !el local variables
20397       integer :: i,j
20398
20399       if(nres.lt.100) then
20400         maxconts=nres
20401       elseif(nres.lt.200) then
20402         maxconts=0.8*nres      ! Max. number of contacts per residue
20403       else
20404         maxconts=0.6*nres ! (maxconts=maxres/4)
20405       endif
20406       maxcont=12*nres      ! Max. number of SC contacts
20407       maxvar=6*nres      ! Max. number of variables
20408 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20409       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20410 !----------------------
20411 ! arrays in subroutine init_int_table
20412 !el#ifdef MPI
20413 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20414 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20415 !el#endif
20416       allocate(nint_gr(nres))
20417       allocate(nscp_gr(nres))
20418       allocate(ielstart(nres))
20419       allocate(ielend(nres))
20420 !(maxres)
20421       allocate(istart(nres,maxint_gr))
20422       allocate(iend(nres,maxint_gr))
20423 !(maxres,maxint_gr)
20424       allocate(iscpstart(nres,maxint_gr))
20425       allocate(iscpend(nres,maxint_gr))
20426 !(maxres,maxint_gr)
20427       allocate(ielstart_vdw(nres))
20428       allocate(ielend_vdw(nres))
20429 !(maxres)
20430       allocate(nint_gr_nucl(nres))
20431       allocate(nscp_gr_nucl(nres))
20432       allocate(ielstart_nucl(nres))
20433       allocate(ielend_nucl(nres))
20434 !(maxres)
20435       allocate(istart_nucl(nres,maxint_gr))
20436       allocate(iend_nucl(nres,maxint_gr))
20437 !(maxres,maxint_gr)
20438       allocate(iscpstart_nucl(nres,maxint_gr))
20439       allocate(iscpend_nucl(nres,maxint_gr))
20440 !(maxres,maxint_gr)
20441       allocate(ielstart_vdw_nucl(nres))
20442       allocate(ielend_vdw_nucl(nres))
20443
20444       allocate(lentyp(0:nfgtasks-1))
20445 !(0:maxprocs-1)
20446 !----------------------
20447 ! commom.contacts
20448 !      common /contacts/
20449       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20450       allocate(icont(2,maxcont))
20451 !(2,maxcont)
20452 !      common /contacts1/
20453       allocate(num_cont(0:nres+4))
20454 !(maxres)
20455       allocate(jcont(maxconts,nres))
20456 !(maxconts,maxres)
20457       allocate(facont(maxconts,nres))
20458 !(maxconts,maxres)
20459       allocate(gacont(3,maxconts,nres))
20460 !(3,maxconts,maxres)
20461 !      common /contacts_hb/
20462       allocate(gacontp_hb1(3,maxconts,nres))
20463       allocate(gacontp_hb2(3,maxconts,nres))
20464       allocate(gacontp_hb3(3,maxconts,nres))
20465       allocate(gacontm_hb1(3,maxconts,nres))
20466       allocate(gacontm_hb2(3,maxconts,nres))
20467       allocate(gacontm_hb3(3,maxconts,nres))
20468       allocate(gacont_hbr(3,maxconts,nres))
20469       allocate(grij_hb_cont(3,maxconts,nres))
20470 !(3,maxconts,maxres)
20471       allocate(facont_hb(maxconts,nres))
20472
20473       allocate(ees0p(maxconts,nres))
20474       allocate(ees0m(maxconts,nres))
20475       allocate(d_cont(maxconts,nres))
20476       allocate(ees0plist(maxconts,nres))
20477
20478 !(maxconts,maxres)
20479       allocate(num_cont_hb(nres))
20480 !(maxres)
20481       allocate(jcont_hb(maxconts,nres))
20482 !(maxconts,maxres)
20483 !      common /rotat/
20484       allocate(Ug(2,2,nres))
20485       allocate(Ugder(2,2,nres))
20486       allocate(Ug2(2,2,nres))
20487       allocate(Ug2der(2,2,nres))
20488 !(2,2,maxres)
20489       allocate(obrot(2,nres))
20490       allocate(obrot2(2,nres))
20491       allocate(obrot_der(2,nres))
20492       allocate(obrot2_der(2,nres))
20493 !(2,maxres)
20494 !      common /precomp1/
20495       allocate(mu(2,nres))
20496       allocate(muder(2,nres))
20497       allocate(Ub2(2,nres))
20498       Ub2(1,:)=0.0d0
20499       Ub2(2,:)=0.0d0
20500       allocate(Ub2der(2,nres))
20501       allocate(Ctobr(2,nres))
20502       allocate(Ctobrder(2,nres))
20503       allocate(Dtobr2(2,nres))
20504       allocate(Dtobr2der(2,nres))
20505 !(2,maxres)
20506       allocate(EUg(2,2,nres))
20507       allocate(EUgder(2,2,nres))
20508       allocate(CUg(2,2,nres))
20509       allocate(CUgder(2,2,nres))
20510       allocate(DUg(2,2,nres))
20511       allocate(Dugder(2,2,nres))
20512       allocate(DtUg2(2,2,nres))
20513       allocate(DtUg2der(2,2,nres))
20514 !(2,2,maxres)
20515 !      common /precomp2/
20516       allocate(Ug2Db1t(2,nres))
20517       allocate(Ug2Db1tder(2,nres))
20518       allocate(CUgb2(2,nres))
20519       allocate(CUgb2der(2,nres))
20520 !(2,maxres)
20521       allocate(EUgC(2,2,nres))
20522       allocate(EUgCder(2,2,nres))
20523       allocate(EUgD(2,2,nres))
20524       allocate(EUgDder(2,2,nres))
20525       allocate(DtUg2EUg(2,2,nres))
20526       allocate(Ug2DtEUg(2,2,nres))
20527 !(2,2,maxres)
20528       allocate(Ug2DtEUgder(2,2,2,nres))
20529       allocate(DtUg2EUgder(2,2,2,nres))
20530 !(2,2,2,maxres)
20531       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20532       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20533       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20534       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20535
20536       allocate(ctilde(2,2,nres))
20537       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20538       allocate(gtb1(2,nres))
20539       allocate(gtb2(2,nres))
20540       allocate(cc(2,2,nres))
20541       allocate(dd(2,2,nres))
20542       allocate(ee(2,2,nres))
20543       allocate(gtcc(2,2,nres))
20544       allocate(gtdd(2,2,nres))
20545       allocate(gtee(2,2,nres))
20546       allocate(gUb2(2,nres))
20547       allocate(gteUg(2,2,nres))
20548
20549 !      common /rotat_old/
20550       allocate(costab(nres))
20551       allocate(sintab(nres))
20552       allocate(costab2(nres))
20553       allocate(sintab2(nres))
20554 !(maxres)
20555 !      common /dipmat/
20556       allocate(a_chuj(2,2,maxconts,nres))
20557 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20558       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20559 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20560 !      common /contdistrib/
20561       allocate(ncont_sent(nres))
20562       allocate(ncont_recv(nres))
20563
20564       allocate(iat_sent(nres))
20565 !(maxres)
20566       allocate(iint_sent(4,nres,nres))
20567       allocate(iint_sent_local(4,nres,nres))
20568 !(4,maxres,maxres)
20569       allocate(iturn3_sent(4,0:nres+4))
20570       allocate(iturn4_sent(4,0:nres+4))
20571       allocate(iturn3_sent_local(4,nres))
20572       allocate(iturn4_sent_local(4,nres))
20573 !(4,maxres)
20574       allocate(itask_cont_from(0:nfgtasks-1))
20575       allocate(itask_cont_to(0:nfgtasks-1))
20576 !(0:max_fg_procs-1)
20577
20578
20579
20580 !----------------------
20581 ! commom.deriv;
20582 !      common /derivat/
20583       allocate(dcdv(6,maxdim))
20584       allocate(dxdv(6,maxdim))
20585 !(6,maxdim)
20586       allocate(dxds(6,nres))
20587 !(6,maxres)
20588       allocate(gradx(3,-1:nres,0:2))
20589       allocate(gradc(3,-1:nres,0:2))
20590 !(3,maxres,2)
20591       allocate(gvdwx(3,-1:nres))
20592       allocate(gvdwc(3,-1:nres))
20593       allocate(gelc(3,-1:nres))
20594       allocate(gelc_long(3,-1:nres))
20595       allocate(gvdwpp(3,-1:nres))
20596       allocate(gvdwc_scpp(3,-1:nres))
20597       allocate(gradx_scp(3,-1:nres))
20598       allocate(gvdwc_scp(3,-1:nres))
20599       allocate(ghpbx(3,-1:nres))
20600       allocate(ghpbc(3,-1:nres))
20601       allocate(gradcorr(3,-1:nres))
20602       allocate(gradcorr_long(3,-1:nres))
20603       allocate(gradcorr5_long(3,-1:nres))
20604       allocate(gradcorr6_long(3,-1:nres))
20605       allocate(gcorr6_turn_long(3,-1:nres))
20606       allocate(gradxorr(3,-1:nres))
20607       allocate(gradcorr5(3,-1:nres))
20608       allocate(gradcorr6(3,-1:nres))
20609       allocate(gliptran(3,-1:nres))
20610       allocate(gliptranc(3,-1:nres))
20611       allocate(gliptranx(3,-1:nres))
20612       allocate(gshieldx(3,-1:nres))
20613       allocate(gshieldc(3,-1:nres))
20614       allocate(gshieldc_loc(3,-1:nres))
20615       allocate(gshieldx_ec(3,-1:nres))
20616       allocate(gshieldc_ec(3,-1:nres))
20617       allocate(gshieldc_loc_ec(3,-1:nres))
20618       allocate(gshieldx_t3(3,-1:nres))
20619       allocate(gshieldc_t3(3,-1:nres))
20620       allocate(gshieldc_loc_t3(3,-1:nres))
20621       allocate(gshieldx_t4(3,-1:nres))
20622       allocate(gshieldc_t4(3,-1:nres))
20623       allocate(gshieldc_loc_t4(3,-1:nres))
20624       allocate(gshieldx_ll(3,-1:nres))
20625       allocate(gshieldc_ll(3,-1:nres))
20626       allocate(gshieldc_loc_ll(3,-1:nres))
20627       allocate(grad_shield(3,-1:nres))
20628       allocate(gg_tube_sc(3,-1:nres))
20629       allocate(gg_tube(3,-1:nres))
20630       allocate(gradafm(3,-1:nres))
20631       allocate(gradb_nucl(3,-1:nres))
20632       allocate(gradbx_nucl(3,-1:nres))
20633       allocate(gvdwpsb1(3,-1:nres))
20634       allocate(gelpp(3,-1:nres))
20635       allocate(gvdwpsb(3,-1:nres))
20636       allocate(gelsbc(3,-1:nres))
20637       allocate(gelsbx(3,-1:nres))
20638       allocate(gvdwsbx(3,-1:nres))
20639       allocate(gvdwsbc(3,-1:nres))
20640       allocate(gsbloc(3,-1:nres))
20641       allocate(gsblocx(3,-1:nres))
20642       allocate(gradcorr_nucl(3,-1:nres))
20643       allocate(gradxorr_nucl(3,-1:nres))
20644       allocate(gradcorr3_nucl(3,-1:nres))
20645       allocate(gradxorr3_nucl(3,-1:nres))
20646       allocate(gvdwpp_nucl(3,-1:nres))
20647       allocate(gradpepcat(3,-1:nres))
20648       allocate(gradpepcatx(3,-1:nres))
20649       allocate(gradcatcat(3,-1:nres))
20650 !(3,maxres)
20651       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20652       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20653 ! grad for shielding surroing
20654       allocate(gloc(0:maxvar,0:2))
20655       allocate(gloc_x(0:maxvar,2))
20656 !(maxvar,2)
20657       allocate(gel_loc(3,-1:nres))
20658       allocate(gel_loc_long(3,-1:nres))
20659       allocate(gcorr3_turn(3,-1:nres))
20660       allocate(gcorr4_turn(3,-1:nres))
20661       allocate(gcorr6_turn(3,-1:nres))
20662       allocate(gradb(3,-1:nres))
20663       allocate(gradbx(3,-1:nres))
20664 !(3,maxres)
20665       allocate(gel_loc_loc(maxvar))
20666       allocate(gel_loc_turn3(maxvar))
20667       allocate(gel_loc_turn4(maxvar))
20668       allocate(gel_loc_turn6(maxvar))
20669       allocate(gcorr_loc(maxvar))
20670       allocate(g_corr5_loc(maxvar))
20671       allocate(g_corr6_loc(maxvar))
20672 !(maxvar)
20673       allocate(gsccorc(3,-1:nres))
20674       allocate(gsccorx(3,-1:nres))
20675 !(3,maxres)
20676       allocate(gsccor_loc(-1:nres))
20677 !(maxres)
20678       allocate(gvdwx_scbase(3,-1:nres))
20679       allocate(gvdwc_scbase(3,-1:nres))
20680       allocate(gvdwx_pepbase(3,-1:nres))
20681       allocate(gvdwc_pepbase(3,-1:nres))
20682       allocate(gvdwx_scpho(3,-1:nres))
20683       allocate(gvdwc_scpho(3,-1:nres))
20684       allocate(gvdwc_peppho(3,-1:nres))
20685
20686       allocate(dtheta(3,2,-1:nres))
20687 !(3,2,maxres)
20688       allocate(gscloc(3,-1:nres))
20689       allocate(gsclocx(3,-1:nres))
20690 !(3,maxres)
20691       allocate(dphi(3,3,-1:nres))
20692       allocate(dalpha(3,3,-1:nres))
20693       allocate(domega(3,3,-1:nres))
20694 !(3,3,maxres)
20695 !      common /deriv_scloc/
20696       allocate(dXX_C1tab(3,nres))
20697       allocate(dYY_C1tab(3,nres))
20698       allocate(dZZ_C1tab(3,nres))
20699       allocate(dXX_Ctab(3,nres))
20700       allocate(dYY_Ctab(3,nres))
20701       allocate(dZZ_Ctab(3,nres))
20702       allocate(dXX_XYZtab(3,nres))
20703       allocate(dYY_XYZtab(3,nres))
20704       allocate(dZZ_XYZtab(3,nres))
20705 !(3,maxres)
20706 !      common /mpgrad/
20707       allocate(jgrad_start(nres))
20708       allocate(jgrad_end(nres))
20709 !(maxres)
20710 !----------------------
20711
20712 !      common /indices/
20713       allocate(ibond_displ(0:nfgtasks-1))
20714       allocate(ibond_count(0:nfgtasks-1))
20715       allocate(ithet_displ(0:nfgtasks-1))
20716       allocate(ithet_count(0:nfgtasks-1))
20717       allocate(iphi_displ(0:nfgtasks-1))
20718       allocate(iphi_count(0:nfgtasks-1))
20719       allocate(iphi1_displ(0:nfgtasks-1))
20720       allocate(iphi1_count(0:nfgtasks-1))
20721       allocate(ivec_displ(0:nfgtasks-1))
20722       allocate(ivec_count(0:nfgtasks-1))
20723       allocate(iset_displ(0:nfgtasks-1))
20724       allocate(iset_count(0:nfgtasks-1))
20725       allocate(iint_count(0:nfgtasks-1))
20726       allocate(iint_displ(0:nfgtasks-1))
20727 !(0:max_fg_procs-1)
20728 !----------------------
20729 ! common.MD
20730 !      common /mdgrad/
20731       allocate(gcart(3,-1:nres))
20732       allocate(gxcart(3,-1:nres))
20733 !(3,0:MAXRES)
20734       allocate(gradcag(3,-1:nres))
20735       allocate(gradxag(3,-1:nres))
20736 !(3,MAXRES)
20737 !      common /back_constr/
20738 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20739       allocate(dutheta(nres))
20740       allocate(dugamma(nres))
20741 !(maxres)
20742       allocate(duscdiff(3,nres))
20743       allocate(duscdiffx(3,nres))
20744 !(3,maxres)
20745 !el i io:read_fragments
20746 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20747 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20748 !      common /qmeas/
20749 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20750 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20751       allocate(mset(0:nprocs))  !(maxprocs/20)
20752       mset(:)=0
20753 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20754 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20755       allocate(dUdconst(3,0:nres))
20756       allocate(dUdxconst(3,0:nres))
20757       allocate(dqwol(3,0:nres))
20758       allocate(dxqwol(3,0:nres))
20759 !(3,0:MAXRES)
20760 !----------------------
20761 ! common.sbridge
20762 !      common /sbridge/ in io_common: read_bridge
20763 !el    allocate((:),allocatable :: iss      !(maxss)
20764 !      common /links/  in io_common: read_bridge
20765 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20766 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20767 !      common /dyn_ssbond/
20768 ! and side-chain vectors in theta or phi.
20769       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20770 !(maxres,maxres)
20771 !      do i=1,nres
20772 !        do j=i+1,nres
20773       dyn_ssbond_ij(:,:)=1.0d300
20774 !        enddo
20775 !      enddo
20776
20777 !      if (nss.gt.0) then
20778         allocate(idssb(maxdim),jdssb(maxdim))
20779 !        allocate(newihpb(nss),newjhpb(nss))
20780 !(maxdim)
20781 !      endif
20782       allocate(ishield_list(-1:nres))
20783       allocate(shield_list(maxcontsshi,-1:nres))
20784       allocate(dyn_ss_mask(nres))
20785       allocate(fac_shield(-1:nres))
20786       allocate(enetube(nres*2))
20787       allocate(enecavtube(nres*2))
20788
20789 !(maxres)
20790       dyn_ss_mask(:)=.false.
20791 !----------------------
20792 ! common.sccor
20793 ! Parameters of the SCCOR term
20794 !      common/sccor/
20795 !el in io_conf: parmread
20796 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20797 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20798 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20799 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20800 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20801 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20802 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20803 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20804 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20805 !----------------
20806       allocate(gloc_sc(3,0:2*nres,0:10))
20807 !(3,0:maxres2,10)maxres2=2*maxres
20808       allocate(dcostau(3,3,3,2*nres))
20809       allocate(dsintau(3,3,3,2*nres))
20810       allocate(dtauangle(3,3,3,2*nres))
20811       allocate(dcosomicron(3,3,3,2*nres))
20812       allocate(domicron(3,3,3,2*nres))
20813 !(3,3,3,maxres2)maxres2=2*maxres
20814 !----------------------
20815 ! common.var
20816 !      common /restr/
20817       allocate(varall(maxvar))
20818 !(maxvar)(maxvar=6*maxres)
20819       allocate(mask_theta(nres))
20820       allocate(mask_phi(nres))
20821       allocate(mask_side(nres))
20822 !(maxres)
20823 !----------------------
20824 ! common.vectors
20825 !      common /vectors/
20826       allocate(uy(3,nres))
20827       allocate(uz(3,nres))
20828 !(3,maxres)
20829       allocate(uygrad(3,3,2,nres))
20830       allocate(uzgrad(3,3,2,nres))
20831 !(3,3,2,maxres)
20832
20833       return
20834       end subroutine alloc_ener_arrays
20835 !-----------------------------------------------------------------
20836       subroutine ebond_nucl(estr_nucl)
20837 !c
20838 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20839 !c
20840
20841       real(kind=8),dimension(3) :: u,ud
20842       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20843       real(kind=8) :: estr_nucl,diff
20844       integer :: iti,i,j,k,nbi
20845       estr_nucl=0.0d0
20846 !C      print *,"I enter ebond"
20847       if (energy_dec) &
20848       write (iout,*) "ibondp_start,ibondp_end",&
20849        ibondp_nucl_start,ibondp_nucl_end
20850       do i=ibondp_nucl_start,ibondp_nucl_end
20851         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20852          itype(i,2).eq.ntyp1_molec(2)) cycle
20853 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20854 !          do j=1,3
20855 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20856 !     &      *dc(j,i-1)/vbld(i)
20857 !          enddo
20858 !          if (energy_dec) write(iout,*)
20859 !     &       "estr1",i,vbld(i),distchainmax,
20860 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20861
20862           diff = vbld(i)-vbldp0_nucl
20863           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20864           vbldp0_nucl,diff,AKP_nucl*diff*diff
20865           estr_nucl=estr_nucl+diff*diff
20866 !          print *,estr_nucl
20867           do j=1,3
20868             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20869           enddo
20870 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20871       enddo
20872       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20873 !      print *,"partial sum", estr_nucl,AKP_nucl
20874
20875       if (energy_dec) &
20876       write (iout,*) "ibondp_start,ibondp_end",&
20877        ibond_nucl_start,ibond_nucl_end
20878
20879       do i=ibond_nucl_start,ibond_nucl_end
20880 !C        print *, "I am stuck",i
20881         iti=itype(i,2)
20882         if (iti.eq.ntyp1_molec(2)) cycle
20883           nbi=nbondterm_nucl(iti)
20884 !C        print *,iti,nbi
20885           if (nbi.eq.1) then
20886             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20887
20888             if (energy_dec) &
20889            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20890            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20891             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20892 !            print *,estr_nucl
20893             do j=1,3
20894               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20895             enddo
20896           else
20897             do j=1,nbi
20898               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20899               ud(j)=aksc_nucl(j,iti)*diff
20900               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20901             enddo
20902             uprod=u(1)
20903             do j=2,nbi
20904               uprod=uprod*u(j)
20905             enddo
20906             usum=0.0d0
20907             usumsqder=0.0d0
20908             do j=1,nbi
20909               uprod1=1.0d0
20910               uprod2=1.0d0
20911               do k=1,nbi
20912                 if (k.ne.j) then
20913                   uprod1=uprod1*u(k)
20914                   uprod2=uprod2*u(k)*u(k)
20915                 endif
20916               enddo
20917               usum=usum+uprod1
20918               usumsqder=usumsqder+ud(j)*uprod2
20919             enddo
20920             estr_nucl=estr_nucl+uprod/usum
20921             do j=1,3
20922              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20923             enddo
20924         endif
20925       enddo
20926 !C      print *,"I am about to leave ebond"
20927       return
20928       end subroutine ebond_nucl
20929
20930 !-----------------------------------------------------------------------------
20931       subroutine ebend_nucl(etheta_nucl)
20932       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20933       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20934       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20935       logical :: lprn=.false., lprn1=.false.
20936 !el local variables
20937       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20938       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20939       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20940 ! local variables for constrains
20941       real(kind=8) :: difi,thetiii
20942        integer itheta
20943       etheta_nucl=0.0D0
20944 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20945       do i=ithet_nucl_start,ithet_nucl_end
20946         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20947         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20948         (itype(i,2).eq.ntyp1_molec(2))) cycle
20949         dethetai=0.0d0
20950         dephii=0.0d0
20951         dephii1=0.0d0
20952         theti2=0.5d0*theta(i)
20953         ityp2=ithetyp_nucl(itype(i-1,2))
20954         do k=1,nntheterm_nucl
20955           coskt(k)=dcos(k*theti2)
20956           sinkt(k)=dsin(k*theti2)
20957         enddo
20958         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20959 #ifdef OSF
20960           phii=phi(i)
20961           if (phii.ne.phii) phii=150.0
20962 #else
20963           phii=phi(i)
20964 #endif
20965           ityp1=ithetyp_nucl(itype(i-2,2))
20966           do k=1,nsingle_nucl
20967             cosph1(k)=dcos(k*phii)
20968             sinph1(k)=dsin(k*phii)
20969           enddo
20970         else
20971           phii=0.0d0
20972           ityp1=nthetyp_nucl+1
20973           do k=1,nsingle_nucl
20974             cosph1(k)=0.0d0
20975             sinph1(k)=0.0d0
20976           enddo
20977         endif
20978
20979         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20980 #ifdef OSF
20981           phii1=phi(i+1)
20982           if (phii1.ne.phii1) phii1=150.0
20983           phii1=pinorm(phii1)
20984 #else
20985           phii1=phi(i+1)
20986 #endif
20987           ityp3=ithetyp_nucl(itype(i,2))
20988           do k=1,nsingle_nucl
20989             cosph2(k)=dcos(k*phii1)
20990             sinph2(k)=dsin(k*phii1)
20991           enddo
20992         else
20993           phii1=0.0d0
20994           ityp3=nthetyp_nucl+1
20995           do k=1,nsingle_nucl
20996             cosph2(k)=0.0d0
20997             sinph2(k)=0.0d0
20998           enddo
20999         endif
21000         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21001         do k=1,ndouble_nucl
21002           do l=1,k-1
21003             ccl=cosph1(l)*cosph2(k-l)
21004             ssl=sinph1(l)*sinph2(k-l)
21005             scl=sinph1(l)*cosph2(k-l)
21006             csl=cosph1(l)*sinph2(k-l)
21007             cosph1ph2(l,k)=ccl-ssl
21008             cosph1ph2(k,l)=ccl+ssl
21009             sinph1ph2(l,k)=scl+csl
21010             sinph1ph2(k,l)=scl-csl
21011           enddo
21012         enddo
21013         if (lprn) then
21014         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21015          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21016         write (iout,*) "coskt and sinkt",nntheterm_nucl
21017         do k=1,nntheterm_nucl
21018           write (iout,*) k,coskt(k),sinkt(k)
21019         enddo
21020         endif
21021         do k=1,ntheterm_nucl
21022           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21023           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21024            *coskt(k)
21025           if (lprn)&
21026          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21027           " ethetai",ethetai
21028         enddo
21029         if (lprn) then
21030         write (iout,*) "cosph and sinph"
21031         do k=1,nsingle_nucl
21032           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21033         enddo
21034         write (iout,*) "cosph1ph2 and sinph2ph2"
21035         do k=2,ndouble_nucl
21036           do l=1,k-1
21037             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21038               sinph1ph2(l,k),sinph1ph2(k,l)
21039           enddo
21040         enddo
21041         write(iout,*) "ethetai",ethetai
21042         endif
21043         do m=1,ntheterm2_nucl
21044           do k=1,nsingle_nucl
21045             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21046               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21047               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21048               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21049             ethetai=ethetai+sinkt(m)*aux
21050             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21051             dephii=dephii+k*sinkt(m)*(&
21052                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21053                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21054             dephii1=dephii1+k*sinkt(m)*(&
21055                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21056                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21057             if (lprn) &
21058            write (iout,*) "m",m," k",k," bbthet",&
21059               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21060               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21061               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21062               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21063           enddo
21064         enddo
21065         if (lprn) &
21066         write(iout,*) "ethetai",ethetai
21067         do m=1,ntheterm3_nucl
21068           do k=2,ndouble_nucl
21069             do l=1,k-1
21070               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21071                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21072                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21073                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21074               ethetai=ethetai+sinkt(m)*aux
21075               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21076               dephii=dephii+l*sinkt(m)*(&
21077                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21078                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21079                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21080                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21081               dephii1=dephii1+(k-l)*sinkt(m)*( &
21082                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21083                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21084                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21085                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21086               if (lprn) then
21087               write (iout,*) "m",m," k",k," l",l," ffthet", &
21088                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21089                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21090                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21091                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21092               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21093                  cosph1ph2(k,l)*sinkt(m),&
21094                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21095               endif
21096             enddo
21097           enddo
21098         enddo
21099 10      continue
21100         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21101         i,theta(i)*rad2deg,phii*rad2deg, &
21102         phii1*rad2deg,ethetai
21103         etheta_nucl=etheta_nucl+ethetai
21104 !        print *,i,"partial sum",etheta_nucl
21105         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21106         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21107         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21108       enddo
21109       return
21110       end subroutine ebend_nucl
21111 !----------------------------------------------------
21112       subroutine etor_nucl(etors_nucl)
21113 !      implicit real*8 (a-h,o-z)
21114 !      include 'DIMENSIONS'
21115 !      include 'COMMON.VAR'
21116 !      include 'COMMON.GEO'
21117 !      include 'COMMON.LOCAL'
21118 !      include 'COMMON.TORSION'
21119 !      include 'COMMON.INTERACT'
21120 !      include 'COMMON.DERIV'
21121 !      include 'COMMON.CHAIN'
21122 !      include 'COMMON.NAMES'
21123 !      include 'COMMON.IOUNITS'
21124 !      include 'COMMON.FFIELD'
21125 !      include 'COMMON.TORCNSTR'
21126 !      include 'COMMON.CONTROL'
21127       real(kind=8) :: etors_nucl,edihcnstr
21128       logical :: lprn
21129 !el local variables
21130       integer :: i,j,iblock,itori,itori1
21131       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21132                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21133 ! Set lprn=.true. for debugging
21134       lprn=.false.
21135 !     lprn=.true.
21136       etors_nucl=0.0D0
21137 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21138       do i=iphi_nucl_start,iphi_nucl_end
21139         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21140              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21141              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21142         etors_ii=0.0D0
21143         itori=itortyp_nucl(itype(i-2,2))
21144         itori1=itortyp_nucl(itype(i-1,2))
21145         phii=phi(i)
21146 !         print *,i,itori,itori1
21147         gloci=0.0D0
21148 !C Regular cosine and sine terms
21149         do j=1,nterm_nucl(itori,itori1)
21150           v1ij=v1_nucl(j,itori,itori1)
21151           v2ij=v2_nucl(j,itori,itori1)
21152           cosphi=dcos(j*phii)
21153           sinphi=dsin(j*phii)
21154           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21155           if (energy_dec) etors_ii=etors_ii+&
21156                      v1ij*cosphi+v2ij*sinphi
21157           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21158         enddo
21159 !C Lorentz terms
21160 !C                         v1
21161 !C  E = SUM ----------------------------------- - v1
21162 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21163 !C
21164         cosphi=dcos(0.5d0*phii)
21165         sinphi=dsin(0.5d0*phii)
21166         do j=1,nlor_nucl(itori,itori1)
21167           vl1ij=vlor1_nucl(j,itori,itori1)
21168           vl2ij=vlor2_nucl(j,itori,itori1)
21169           vl3ij=vlor3_nucl(j,itori,itori1)
21170           pom=vl2ij*cosphi+vl3ij*sinphi
21171           pom1=1.0d0/(pom*pom+1.0d0)
21172           etors_nucl=etors_nucl+vl1ij*pom1
21173           if (energy_dec) etors_ii=etors_ii+ &
21174                      vl1ij*pom1
21175           pom=-pom*pom1*pom1
21176           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21177         enddo
21178 !C Subtract the constant term
21179         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21180           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21181               'etor',i,etors_ii-v0_nucl(itori,itori1)
21182         if (lprn) &
21183        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21184        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21185        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21186         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21187 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21188       enddo
21189       return
21190       end subroutine etor_nucl
21191 !------------------------------------------------------------
21192       subroutine epp_nucl_sub(evdw1,ees)
21193 !C
21194 !C This subroutine calculates the average interaction energy and its gradient
21195 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21196 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21197 !C The potential depends both on the distance of peptide-group centers and on
21198 !C the orientation of the CA-CA virtual bonds.
21199 !C
21200       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21201       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21202       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21203                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21204                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21205       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21206                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21207       integer xshift,yshift,zshift
21208       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21209       real(kind=8) :: ees,eesij
21210 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21211       real(kind=8) scal_el /0.5d0/
21212       t_eelecij=0.0d0
21213       ees=0.0D0
21214       evdw1=0.0D0
21215       ind=0
21216 !c
21217 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21218 !c
21219 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21220       do i=iatel_s_nucl,iatel_e_nucl
21221         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21222         dxi=dc(1,i)
21223         dyi=dc(2,i)
21224         dzi=dc(3,i)
21225         dx_normi=dc_norm(1,i)
21226         dy_normi=dc_norm(2,i)
21227         dz_normi=dc_norm(3,i)
21228         xmedi=c(1,i)+0.5d0*dxi
21229         ymedi=c(2,i)+0.5d0*dyi
21230         zmedi=c(3,i)+0.5d0*dzi
21231           xmedi=dmod(xmedi,boxxsize)
21232           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21233           ymedi=dmod(ymedi,boxysize)
21234           if (ymedi.lt.0) ymedi=ymedi+boxysize
21235           zmedi=dmod(zmedi,boxzsize)
21236           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21237
21238         do j=ielstart_nucl(i),ielend_nucl(i)
21239           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21240           ind=ind+1
21241           dxj=dc(1,j)
21242           dyj=dc(2,j)
21243           dzj=dc(3,j)
21244 !          xj=c(1,j)+0.5D0*dxj-xmedi
21245 !          yj=c(2,j)+0.5D0*dyj-ymedi
21246 !          zj=c(3,j)+0.5D0*dzj-zmedi
21247           xj=c(1,j)+0.5D0*dxj
21248           yj=c(2,j)+0.5D0*dyj
21249           zj=c(3,j)+0.5D0*dzj
21250           xj=mod(xj,boxxsize)
21251           if (xj.lt.0) xj=xj+boxxsize
21252           yj=mod(yj,boxysize)
21253           if (yj.lt.0) yj=yj+boxysize
21254           zj=mod(zj,boxzsize)
21255           if (zj.lt.0) zj=zj+boxzsize
21256       isubchap=0
21257       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21258       xj_safe=xj
21259       yj_safe=yj
21260       zj_safe=zj
21261       do xshift=-1,1
21262       do yshift=-1,1
21263       do zshift=-1,1
21264           xj=xj_safe+xshift*boxxsize
21265           yj=yj_safe+yshift*boxysize
21266           zj=zj_safe+zshift*boxzsize
21267           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21268           if(dist_temp.lt.dist_init) then
21269             dist_init=dist_temp
21270             xj_temp=xj
21271             yj_temp=yj
21272             zj_temp=zj
21273             isubchap=1
21274           endif
21275        enddo
21276        enddo
21277        enddo
21278        if (isubchap.eq.1) then
21279 !C          print *,i,j
21280           xj=xj_temp-xmedi
21281           yj=yj_temp-ymedi
21282           zj=zj_temp-zmedi
21283        else
21284           xj=xj_safe-xmedi
21285           yj=yj_safe-ymedi
21286           zj=zj_safe-zmedi
21287        endif
21288
21289           rij=xj*xj+yj*yj+zj*zj
21290 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21291           fac=(r0pp**2/rij)**3
21292           ev1=epspp*fac*fac
21293           ev2=epspp*fac
21294           evdw1ij=ev1-2*ev2
21295           fac=(-ev1-evdw1ij)/rij
21296 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21297           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21298           evdw1=evdw1+evdw1ij
21299 !C
21300 !C Calculate contributions to the Cartesian gradient.
21301 !C
21302           ggg(1)=fac*xj
21303           ggg(2)=fac*yj
21304           ggg(3)=fac*zj
21305           do k=1,3
21306             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21307             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21308           enddo
21309 !c phoshate-phosphate electrostatic interactions
21310           rij=dsqrt(rij)
21311           fac=1.0d0/rij
21312           eesij=dexp(-BEES*rij)*fac
21313 !          write (2,*)"fac",fac," eesijpp",eesij
21314           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21315           ees=ees+eesij
21316 !c          fac=-eesij*fac
21317           fac=-(fac+BEES)*eesij*fac
21318           ggg(1)=fac*xj
21319           ggg(2)=fac*yj
21320           ggg(3)=fac*zj
21321 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21322 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21323 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21324           do k=1,3
21325             gelpp(k,i)=gelpp(k,i)-ggg(k)
21326             gelpp(k,j)=gelpp(k,j)+ggg(k)
21327           enddo
21328         enddo ! j
21329       enddo   ! i
21330 !c      ees=332.0d0*ees
21331       ees=AEES*ees
21332       do i=nnt,nct
21333 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21334         do k=1,3
21335           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21336 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21337           gelpp(k,i)=AEES*gelpp(k,i)
21338         enddo
21339 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21340       enddo
21341 !c      write (2,*) "total EES",ees
21342       return
21343       end subroutine epp_nucl_sub
21344 !---------------------------------------------------------------------
21345       subroutine epsb(evdwpsb,eelpsb)
21346 !      use comm_locel
21347 !C
21348 !C This subroutine calculates the excluded-volume interaction energy between
21349 !C peptide-group centers and side chains and its gradient in virtual-bond and
21350 !C side-chain vectors.
21351 !C
21352       real(kind=8),dimension(3):: ggg
21353       integer :: i,iint,j,k,iteli,itypj,subchap
21354       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21355                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21356       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21357                     dist_temp, dist_init
21358       integer xshift,yshift,zshift
21359
21360 !cd    print '(a)','Enter ESCP'
21361 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21362       eelpsb=0.0d0
21363       evdwpsb=0.0d0
21364 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21365       do i=iatscp_s_nucl,iatscp_e_nucl
21366         if (itype(i,2).eq.ntyp1_molec(2) &
21367          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21368         xi=0.5D0*(c(1,i)+c(1,i+1))
21369         yi=0.5D0*(c(2,i)+c(2,i+1))
21370         zi=0.5D0*(c(3,i)+c(3,i+1))
21371           xi=mod(xi,boxxsize)
21372           if (xi.lt.0) xi=xi+boxxsize
21373           yi=mod(yi,boxysize)
21374           if (yi.lt.0) yi=yi+boxysize
21375           zi=mod(zi,boxzsize)
21376           if (zi.lt.0) zi=zi+boxzsize
21377
21378         do iint=1,nscp_gr_nucl(i)
21379
21380         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21381           itypj=itype(j,2)
21382           if (itypj.eq.ntyp1_molec(2)) cycle
21383 !C Uncomment following three lines for SC-p interactions
21384 !c         xj=c(1,nres+j)-xi
21385 !c         yj=c(2,nres+j)-yi
21386 !c         zj=c(3,nres+j)-zi
21387 !C Uncomment following three lines for Ca-p interactions
21388 !          xj=c(1,j)-xi
21389 !          yj=c(2,j)-yi
21390 !          zj=c(3,j)-zi
21391           xj=c(1,j)
21392           yj=c(2,j)
21393           zj=c(3,j)
21394           xj=mod(xj,boxxsize)
21395           if (xj.lt.0) xj=xj+boxxsize
21396           yj=mod(yj,boxysize)
21397           if (yj.lt.0) yj=yj+boxysize
21398           zj=mod(zj,boxzsize)
21399           if (zj.lt.0) zj=zj+boxzsize
21400       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21401       xj_safe=xj
21402       yj_safe=yj
21403       zj_safe=zj
21404       subchap=0
21405       do xshift=-1,1
21406       do yshift=-1,1
21407       do zshift=-1,1
21408           xj=xj_safe+xshift*boxxsize
21409           yj=yj_safe+yshift*boxysize
21410           zj=zj_safe+zshift*boxzsize
21411           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21412           if(dist_temp.lt.dist_init) then
21413             dist_init=dist_temp
21414             xj_temp=xj
21415             yj_temp=yj
21416             zj_temp=zj
21417             subchap=1
21418           endif
21419        enddo
21420        enddo
21421        enddo
21422        if (subchap.eq.1) then
21423           xj=xj_temp-xi
21424           yj=yj_temp-yi
21425           zj=zj_temp-zi
21426        else
21427           xj=xj_safe-xi
21428           yj=yj_safe-yi
21429           zj=zj_safe-zi
21430        endif
21431
21432           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21433           fac=rrij**expon2
21434           e1=fac*fac*aad_nucl(itypj)
21435           e2=fac*bad_nucl(itypj)
21436           if (iabs(j-i) .le. 2) then
21437             e1=scal14*e1
21438             e2=scal14*e2
21439           endif
21440           evdwij=e1+e2
21441           evdwpsb=evdwpsb+evdwij
21442           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21443              'evdw2',i,j,evdwij,"tu4"
21444 !C
21445 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21446 !C
21447           fac=-(evdwij+e1)*rrij
21448           ggg(1)=xj*fac
21449           ggg(2)=yj*fac
21450           ggg(3)=zj*fac
21451           do k=1,3
21452             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21453             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21454           enddo
21455         enddo
21456
21457         enddo ! iint
21458       enddo ! i
21459       do i=1,nct
21460         do j=1,3
21461           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21462           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21463         enddo
21464       enddo
21465       return
21466       end subroutine epsb
21467
21468 !------------------------------------------------------
21469       subroutine esb_gb(evdwsb,eelsb)
21470       use comm_locel
21471       use calc_data_nucl
21472       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21473       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21474       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21475       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21476                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21477       integer :: ii
21478       logical lprn
21479       evdw=0.0D0
21480       eelsb=0.0d0
21481       ecorr=0.0d0
21482       evdwsb=0.0D0
21483       lprn=.false.
21484       ind=0
21485 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21486       do i=iatsc_s_nucl,iatsc_e_nucl
21487         num_conti=0
21488         num_conti2=0
21489         itypi=itype(i,2)
21490 !        PRINT *,"I=",i,itypi
21491         if (itypi.eq.ntyp1_molec(2)) cycle
21492         itypi1=itype(i+1,2)
21493         xi=c(1,nres+i)
21494         yi=c(2,nres+i)
21495         zi=c(3,nres+i)
21496           xi=dmod(xi,boxxsize)
21497           if (xi.lt.0) xi=xi+boxxsize
21498           yi=dmod(yi,boxysize)
21499           if (yi.lt.0) yi=yi+boxysize
21500           zi=dmod(zi,boxzsize)
21501           if (zi.lt.0) zi=zi+boxzsize
21502
21503         dxi=dc_norm(1,nres+i)
21504         dyi=dc_norm(2,nres+i)
21505         dzi=dc_norm(3,nres+i)
21506         dsci_inv=vbld_inv(i+nres)
21507 !C
21508 !C Calculate SC interaction energy.
21509 !C
21510         do iint=1,nint_gr_nucl(i)
21511 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21512           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21513             ind=ind+1
21514 !            print *,"JESTEM"
21515             itypj=itype(j,2)
21516             if (itypj.eq.ntyp1_molec(2)) cycle
21517             dscj_inv=vbld_inv(j+nres)
21518             sig0ij=sigma_nucl(itypi,itypj)
21519             chi1=chi_nucl(itypi,itypj)
21520             chi2=chi_nucl(itypj,itypi)
21521             chi12=chi1*chi2
21522             chip1=chip_nucl(itypi,itypj)
21523             chip2=chip_nucl(itypj,itypi)
21524             chip12=chip1*chip2
21525 !            xj=c(1,nres+j)-xi
21526 !            yj=c(2,nres+j)-yi
21527 !            zj=c(3,nres+j)-zi
21528            xj=c(1,nres+j)
21529            yj=c(2,nres+j)
21530            zj=c(3,nres+j)
21531           xj=dmod(xj,boxxsize)
21532           if (xj.lt.0) xj=xj+boxxsize
21533           yj=dmod(yj,boxysize)
21534           if (yj.lt.0) yj=yj+boxysize
21535           zj=dmod(zj,boxzsize)
21536           if (zj.lt.0) zj=zj+boxzsize
21537       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21538       xj_safe=xj
21539       yj_safe=yj
21540       zj_safe=zj
21541       subchap=0
21542       do xshift=-1,1
21543       do yshift=-1,1
21544       do zshift=-1,1
21545           xj=xj_safe+xshift*boxxsize
21546           yj=yj_safe+yshift*boxysize
21547           zj=zj_safe+zshift*boxzsize
21548           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21549           if(dist_temp.lt.dist_init) then
21550             dist_init=dist_temp
21551             xj_temp=xj
21552             yj_temp=yj
21553             zj_temp=zj
21554             subchap=1
21555           endif
21556        enddo
21557        enddo
21558        enddo
21559        if (subchap.eq.1) then
21560           xj=xj_temp-xi
21561           yj=yj_temp-yi
21562           zj=zj_temp-zi
21563        else
21564           xj=xj_safe-xi
21565           yj=yj_safe-yi
21566           zj=zj_safe-zi
21567        endif
21568
21569             dxj=dc_norm(1,nres+j)
21570             dyj=dc_norm(2,nres+j)
21571             dzj=dc_norm(3,nres+j)
21572             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21573             rij=dsqrt(rrij)
21574 !C Calculate angle-dependent terms of energy and contributions to their
21575 !C derivatives.
21576             erij(1)=xj*rij
21577             erij(2)=yj*rij
21578             erij(3)=zj*rij
21579             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21580             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21581             om12=dxi*dxj+dyi*dyj+dzi*dzj
21582             call sc_angular_nucl
21583             sigsq=1.0D0/sigsq
21584             sig=sig0ij*dsqrt(sigsq)
21585             rij_shift=1.0D0/rij-sig+sig0ij
21586 !            print *,rij_shift,"rij_shift"
21587 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21588 !c     &       " rij_shift",rij_shift
21589             if (rij_shift.le.0.0D0) then
21590               evdw=1.0D20
21591               return
21592             endif
21593             sigder=-sig*sigsq
21594 !c---------------------------------------------------------------
21595             rij_shift=1.0D0/rij_shift
21596             fac=rij_shift**expon
21597             e1=fac*fac*aa_nucl(itypi,itypj)
21598             e2=fac*bb_nucl(itypi,itypj)
21599             evdwij=eps1*eps2rt*(e1+e2)
21600 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21601 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21602             eps2der=evdwij
21603             evdwij=evdwij*eps2rt
21604             evdwsb=evdwsb+evdwij
21605             if (lprn) then
21606             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21607             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21608             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21609              restyp(itypi,2),i,restyp(itypj,2),j, &
21610              epsi,sigm,chi1,chi2,chip1,chip2, &
21611              eps1,eps2rt**2,sig,sig0ij, &
21612              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21613             evdwij
21614             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21615             endif
21616
21617             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21618                              'evdw',i,j,evdwij,"tu3"
21619
21620
21621 !C Calculate gradient components.
21622             e1=e1*eps1*eps2rt**2
21623             fac=-expon*(e1+evdwij)*rij_shift
21624             sigder=fac*sigder
21625             fac=rij*fac
21626 !c            fac=0.0d0
21627 !C Calculate the radial part of the gradient
21628             gg(1)=xj*fac
21629             gg(2)=yj*fac
21630             gg(3)=zj*fac
21631 !C Calculate angular part of the gradient.
21632             call sc_grad_nucl
21633             call eelsbij(eelij,num_conti2)
21634             if (energy_dec .and. &
21635            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21636           write (istat,'(e14.5)') evdwij
21637             eelsb=eelsb+eelij
21638           enddo      ! j
21639         enddo        ! iint
21640         num_cont_hb(i)=num_conti2
21641       enddo          ! i
21642 !c      write (iout,*) "Number of loop steps in EGB:",ind
21643 !cccc      energy_dec=.false.
21644       return
21645       end subroutine esb_gb
21646 !-------------------------------------------------------------------------------
21647       subroutine eelsbij(eesij,num_conti2)
21648       use comm_locel
21649       use calc_data_nucl
21650       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21651       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21652       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21653                     dist_temp, dist_init,rlocshield,fracinbuf
21654       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21655
21656 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21657       real(kind=8) scal_el /0.5d0/
21658       integer :: iteli,itelj,kkk,kkll,m,isubchap
21659       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21660       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21661       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21662                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21663                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21664                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21665                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21666                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21667                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21668                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21669       ind=ind+1
21670       itypi=itype(i,2)
21671       itypj=itype(j,2)
21672 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21673       ael6i=ael6_nucl(itypi,itypj)
21674       ael3i=ael3_nucl(itypi,itypj)
21675       ael63i=ael63_nucl(itypi,itypj)
21676       ael32i=ael32_nucl(itypi,itypj)
21677 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21678 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21679       dxj=dc(1,j+nres)
21680       dyj=dc(2,j+nres)
21681       dzj=dc(3,j+nres)
21682       dx_normi=dc_norm(1,i+nres)
21683       dy_normi=dc_norm(2,i+nres)
21684       dz_normi=dc_norm(3,i+nres)
21685       dx_normj=dc_norm(1,j+nres)
21686       dy_normj=dc_norm(2,j+nres)
21687       dz_normj=dc_norm(3,j+nres)
21688 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21689 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21690 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21691       if (ipot_nucl.ne.2) then
21692         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21693         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21694         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21695       else
21696         cosa=om12
21697         cosb=om1
21698         cosg=om2
21699       endif
21700       r3ij=rij*rrij
21701       r6ij=r3ij*r3ij
21702       fac=cosa-3.0D0*cosb*cosg
21703       facfac=fac*fac
21704       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21705       fac3=ael6i*r6ij
21706       fac4=ael3i*r3ij
21707       fac5=ael63i*r6ij
21708       fac6=ael32i*r6ij
21709 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21710 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21711       el1=fac3*(4.0D0+facfac-fac1)
21712       el2=fac4*fac
21713       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21714       el4=fac6*facfac
21715       eesij=el1+el2+el3+el4
21716 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21717       ees0ij=4.0D0+facfac-fac1
21718
21719       if (energy_dec) then
21720           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21721           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21722            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21723            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21724            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21725           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21726       endif
21727
21728 !C
21729 !C Calculate contributions to the Cartesian gradient.
21730 !C
21731       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21732       fac1=fac
21733 !c      erij(1)=xj*rmij
21734 !c      erij(2)=yj*rmij
21735 !c      erij(3)=zj*rmij
21736 !*
21737 !* Radial derivatives. First process both termini of the fragment (i,j)
21738 !*
21739       ggg(1)=facel*xj
21740       ggg(2)=facel*yj
21741       ggg(3)=facel*zj
21742       do k=1,3
21743         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21744         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21745         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21746         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21747       enddo
21748 !*
21749 !* Angular part
21750 !*
21751       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21752       fac4=-3.0D0*fac4
21753       fac3=-6.0D0*fac3
21754       fac5= 6.0d0*fac5
21755       fac6=-6.0d0*fac6
21756       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21757        fac6*fac1*cosg
21758       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21759        fac6*fac1*cosb
21760       do k=1,3
21761         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21762         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21763       enddo
21764       do k=1,3
21765         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21766       enddo
21767       do k=1,3
21768         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21769              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21770              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21771         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21772              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21773              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21774         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21775         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21776       enddo
21777 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21778        IF ( j.gt.i+1 .and.&
21779           num_conti.le.maxconts) THEN
21780 !C
21781 !C Calculate the contact function. The ith column of the array JCONT will
21782 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21783 !C greater than I). The arrays FACONT and GACONT will contain the values of
21784 !C the contact function and its derivative.
21785         r0ij=2.20D0*sigma(itypi,itypj)
21786 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21787         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21788 !c        write (2,*) "fcont",fcont
21789         if (fcont.gt.0.0D0) then
21790           num_conti=num_conti+1
21791           num_conti2=num_conti2+1
21792
21793           if (num_conti.gt.maxconts) then
21794             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21795                           ' will skip next contacts for this conf.'
21796           else
21797             jcont_hb(num_conti,i)=j
21798 !c            write (iout,*) "num_conti",num_conti,
21799 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21800 !C Calculate contact energies
21801             cosa4=4.0D0*cosa
21802             wij=cosa-3.0D0*cosb*cosg
21803             cosbg1=cosb+cosg
21804             cosbg2=cosb-cosg
21805             fac3=dsqrt(-ael6i)*r3ij
21806 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21807             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21808             if (ees0tmp.gt.0) then
21809               ees0pij=dsqrt(ees0tmp)
21810             else
21811               ees0pij=0
21812             endif
21813             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21814             if (ees0tmp.gt.0) then
21815               ees0mij=dsqrt(ees0tmp)
21816             else
21817               ees0mij=0
21818             endif
21819             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21820             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21821 !c            write (iout,*) "i",i," j",j,
21822 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21823             ees0pij1=fac3/ees0pij
21824             ees0mij1=fac3/ees0mij
21825             fac3p=-3.0D0*fac3*rrij
21826             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21827             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21828             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21829             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21830             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21831             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21832             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21833             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21834             ecosap=ecosa1+ecosa2
21835             ecosbp=ecosb1+ecosb2
21836             ecosgp=ecosg1+ecosg2
21837             ecosam=ecosa1-ecosa2
21838             ecosbm=ecosb1-ecosb2
21839             ecosgm=ecosg1-ecosg2
21840 !C End diagnostics
21841             facont_hb(num_conti,i)=fcont
21842             fprimcont=fprimcont/rij
21843             do k=1,3
21844               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21845               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21846             enddo
21847             gggp(1)=gggp(1)+ees0pijp*xj
21848             gggp(2)=gggp(2)+ees0pijp*yj
21849             gggp(3)=gggp(3)+ees0pijp*zj
21850             gggm(1)=gggm(1)+ees0mijp*xj
21851             gggm(2)=gggm(2)+ees0mijp*yj
21852             gggm(3)=gggm(3)+ees0mijp*zj
21853 !C Derivatives due to the contact function
21854             gacont_hbr(1,num_conti,i)=fprimcont*xj
21855             gacont_hbr(2,num_conti,i)=fprimcont*yj
21856             gacont_hbr(3,num_conti,i)=fprimcont*zj
21857             do k=1,3
21858 !c
21859 !c Gradient of the correlation terms
21860 !c
21861               gacontp_hb1(k,num_conti,i)= &
21862              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21863             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21864               gacontp_hb2(k,num_conti,i)= &
21865              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21866             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21867               gacontp_hb3(k,num_conti,i)=gggp(k)
21868               gacontm_hb1(k,num_conti,i)= &
21869              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21870             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21871               gacontm_hb2(k,num_conti,i)= &
21872              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21873             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21874               gacontm_hb3(k,num_conti,i)=gggm(k)
21875             enddo
21876           endif
21877         endif
21878       ENDIF
21879       return
21880       end subroutine eelsbij
21881 !------------------------------------------------------------------
21882       subroutine sc_grad_nucl
21883       use comm_locel
21884       use calc_data_nucl
21885       real(kind=8),dimension(3) :: dcosom1,dcosom2
21886       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21887       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21888       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21889       do k=1,3
21890         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21891         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21892       enddo
21893       do k=1,3
21894         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21895       enddo
21896       do k=1,3
21897         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21898                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21899                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21900         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21901                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21902                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21903       enddo
21904 !C
21905 !C Calculate the components of the gradient in DC and X
21906 !C
21907       do l=1,3
21908         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21909         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21910       enddo
21911       return
21912       end subroutine sc_grad_nucl
21913 !-----------------------------------------------------------------------
21914       subroutine esb(esbloc)
21915 !C Calculate the local energy of a side chain and its derivatives in the
21916 !C corresponding virtual-bond valence angles THETA and the spherical angles
21917 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21918 !C added by Urszula Kozlowska. 07/11/2007
21919 !C
21920       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21921       real(kind=8),dimension(9):: x
21922      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21923       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21924       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21925       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21926        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21927        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21928        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21929        integer::it,nlobit,i,j,k
21930 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21931       delta=0.02d0*pi
21932       esbloc=0.0D0
21933       do i=loc_start_nucl,loc_end_nucl
21934         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21935         costtab(i+1) =dcos(theta(i+1))
21936         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21937         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21938         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21939         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21940         cosfac=dsqrt(cosfac2)
21941         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21942         sinfac=dsqrt(sinfac2)
21943         it=itype(i,2)
21944         if (it.eq.10) goto 1
21945
21946 !c
21947 !C  Compute the axes of tghe local cartesian coordinates system; store in
21948 !c   x_prime, y_prime and z_prime
21949 !c
21950         do j=1,3
21951           x_prime(j) = 0.00
21952           y_prime(j) = 0.00
21953           z_prime(j) = 0.00
21954         enddo
21955 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21956 !C     &   dc_norm(3,i+nres)
21957         do j = 1,3
21958           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21959           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21960         enddo
21961         do j = 1,3
21962           z_prime(j) = -uz(j,i-1)
21963 !           z_prime(j)=0.0
21964         enddo
21965
21966         xx=0.0d0
21967         yy=0.0d0
21968         zz=0.0d0
21969         do j = 1,3
21970           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21971           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21972           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21973         enddo
21974
21975         xxtab(i)=xx
21976         yytab(i)=yy
21977         zztab(i)=zz
21978          it=itype(i,2)
21979         do j = 1,9
21980           x(j) = sc_parmin_nucl(j,it)
21981         enddo
21982 #ifdef CHECK_COORD
21983 !Cc diagnostics - remove later
21984         xx1 = dcos(alph(2))
21985         yy1 = dsin(alph(2))*dcos(omeg(2))
21986         zz1 = -dsin(alph(2))*dsin(omeg(2))
21987         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21988          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21989          xx1,yy1,zz1
21990 !C,"  --- ", xx_w,yy_w,zz_w
21991 !c end diagnostics
21992 #endif
21993         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21994         esbloc = esbloc + sumene
21995         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21996 !        print *,"enecomp",sumene,sumene2
21997 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21998 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21999 #ifdef DEBUG
22000         write (2,*) "x",(x(k),k=1,9)
22001 !C
22002 !C This section to check the numerical derivatives of the energy of ith side
22003 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22004 !C #define DEBUG in the code to turn it on.
22005 !C
22006         write (2,*) "sumene               =",sumene
22007         aincr=1.0d-7
22008         xxsave=xx
22009         xx=xx+aincr
22010         write (2,*) xx,yy,zz
22011         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22012         de_dxx_num=(sumenep-sumene)/aincr
22013         xx=xxsave
22014         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22015         yysave=yy
22016         yy=yy+aincr
22017         write (2,*) xx,yy,zz
22018         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22019         de_dyy_num=(sumenep-sumene)/aincr
22020         yy=yysave
22021         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22022         zzsave=zz
22023         zz=zz+aincr
22024         write (2,*) xx,yy,zz
22025         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22026         de_dzz_num=(sumenep-sumene)/aincr
22027         zz=zzsave
22028         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22029         costsave=cost2tab(i+1)
22030         sintsave=sint2tab(i+1)
22031         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22032         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22033         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22034         de_dt_num=(sumenep-sumene)/aincr
22035         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22036         cost2tab(i+1)=costsave
22037         sint2tab(i+1)=sintsave
22038 !C End of diagnostics section.
22039 #endif
22040 !C
22041 !C Compute the gradient of esc
22042 !C
22043         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22044         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22045         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22046         de_dtt=0.0d0
22047 #ifdef DEBUG
22048         write (2,*) "x",(x(k),k=1,9)
22049         write (2,*) "xx",xx," yy",yy," zz",zz
22050         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22051           " de_zz   ",de_zz," de_tt   ",de_tt
22052         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22053           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22054 #endif
22055 !C
22056        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22057        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22058        cosfac2xx=cosfac2*xx
22059        sinfac2yy=sinfac2*yy
22060        do k = 1,3
22061          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22062            vbld_inv(i+1)
22063          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22064            vbld_inv(i)
22065          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22066          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22067 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22068 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22069 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22070 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22071          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22072          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22073          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22074          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22075          dZZ_Ci1(k)=0.0d0
22076          dZZ_Ci(k)=0.0d0
22077          do j=1,3
22078            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22079            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22080          enddo
22081
22082          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22083          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22084          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22085 !c
22086          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22087          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22088        enddo
22089
22090        do k=1,3
22091          dXX_Ctab(k,i)=dXX_Ci(k)
22092          dXX_C1tab(k,i)=dXX_Ci1(k)
22093          dYY_Ctab(k,i)=dYY_Ci(k)
22094          dYY_C1tab(k,i)=dYY_Ci1(k)
22095          dZZ_Ctab(k,i)=dZZ_Ci(k)
22096          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22097          dXX_XYZtab(k,i)=dXX_XYZ(k)
22098          dYY_XYZtab(k,i)=dYY_XYZ(k)
22099          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22100        enddo
22101        do k = 1,3
22102 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22103 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22104 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22105 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22106 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22107 !c     &    dt_dci(k)
22108 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22109 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22110          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22111          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22112          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22113          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22114          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22115          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22116 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22117        enddo
22118 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22119 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22120
22121 !C to check gradient call subroutine check_grad
22122
22123     1 continue
22124       enddo
22125       return
22126       end subroutine esb
22127 !=-------------------------------------------------------
22128       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22129 !      implicit none
22130       real(kind=8),dimension(9):: x(9)
22131        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22132       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22133       integer i
22134 !c      write (2,*) "enesc"
22135 !c      write (2,*) "x",(x(i),i=1,9)
22136 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22137       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22138         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22139         + x(9)*yy*zz
22140       enesc_nucl=sumene
22141       return
22142       end function enesc_nucl
22143 !-----------------------------------------------------------------------------
22144       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22145 #ifdef MPI
22146       include 'mpif.h'
22147       integer,parameter :: max_cont=2000
22148       integer,parameter:: max_dim=2*(8*3+6)
22149       integer, parameter :: msglen1=max_cont*max_dim
22150       integer,parameter :: msglen2=2*msglen1
22151       integer source,CorrelType,CorrelID,Error
22152       real(kind=8) :: buffer(max_cont,max_dim)
22153       integer status(MPI_STATUS_SIZE)
22154       integer :: ierror,nbytes
22155 #endif
22156       real(kind=8),dimension(3):: gx(3),gx1(3)
22157       real(kind=8) :: time00
22158       logical lprn,ldone
22159       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22160       real(kind=8) ecorr,ecorr3
22161       integer :: n_corr,n_corr1,mm,msglen
22162 !C Set lprn=.true. for debugging
22163       lprn=.false.
22164       n_corr=0
22165       n_corr1=0
22166 #ifdef MPI
22167       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22168
22169       if (nfgtasks.le.1) goto 30
22170       if (lprn) then
22171         write (iout,'(a)') 'Contact function values:'
22172         do i=nnt,nct-1
22173           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22174          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22175          j=1,num_cont_hb(i))
22176         enddo
22177       endif
22178 !C Caution! Following code assumes that electrostatic interactions concerning
22179 !C a given atom are split among at most two processors!
22180       CorrelType=477
22181       CorrelID=fg_rank+1
22182       ldone=.false.
22183       do i=1,max_cont
22184         do j=1,max_dim
22185           buffer(i,j)=0.0D0
22186         enddo
22187       enddo
22188       mm=mod(fg_rank,2)
22189 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22190       if (mm) 20,20,10
22191    10 continue
22192 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22193       if (fg_rank.gt.0) then
22194 !C Send correlation contributions to the preceding processor
22195         msglen=msglen1
22196         nn=num_cont_hb(iatel_s_nucl)
22197         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22198 !c        write (*,*) 'The BUFFER array:'
22199 !c        do i=1,nn
22200 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22201 !c        enddo
22202         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22203           msglen=msglen2
22204           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22205 !C Clear the contacts of the atom passed to the neighboring processor
22206         nn=num_cont_hb(iatel_s_nucl+1)
22207 !c        do i=1,nn
22208 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22209 !c        enddo
22210             num_cont_hb(iatel_s_nucl)=0
22211         endif
22212 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22213 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22214 !cd   & ' msglen=',msglen
22215 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22216 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22217 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22218         time00=MPI_Wtime()
22219         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22220          CorrelType,FG_COMM,IERROR)
22221         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22222 !cd      write (iout,*) 'Processor ',fg_rank,
22223 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22224 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22225 !c        write (*,*) 'Processor ',fg_rank,
22226 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22227 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22228 !c        msglen=msglen1
22229       endif ! (fg_rank.gt.0)
22230       if (ldone) goto 30
22231       ldone=.true.
22232    20 continue
22233 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22234       if (fg_rank.lt.nfgtasks-1) then
22235 !C Receive correlation contributions from the next processor
22236         msglen=msglen1
22237         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22238 !cd      write (iout,*) 'Processor',fg_rank,
22239 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22240 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22241 !c        write (*,*) 'Processor',fg_rank,
22242 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22243 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22244         time00=MPI_Wtime()
22245         nbytes=-1
22246         do while (nbytes.le.0)
22247           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22248           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22249         enddo
22250 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22251         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22252          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22253         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22254 !c        write (*,*) 'Processor',fg_rank,
22255 !c     &' has received correlation contribution from processor',fg_rank+1,
22256 !c     & ' msglen=',msglen,' nbytes=',nbytes
22257 !c        write (*,*) 'The received BUFFER array:'
22258 !c        do i=1,max_cont
22259 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22260 !c        enddo
22261         if (msglen.eq.msglen1) then
22262           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22263         else if (msglen.eq.msglen2)  then
22264           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22265           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22266         else
22267           write (iout,*) &
22268       'ERROR!!!! message length changed while processing correlations.'
22269           write (*,*) &
22270       'ERROR!!!! message length changed while processing correlations.'
22271           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22272         endif ! msglen.eq.msglen1
22273       endif ! fg_rank.lt.nfgtasks-1
22274       if (ldone) goto 30
22275       ldone=.true.
22276       goto 10
22277    30 continue
22278 #endif
22279       if (lprn) then
22280         write (iout,'(a)') 'Contact function values:'
22281         do i=nnt_molec(2),nct_molec(2)-1
22282           write (iout,'(2i3,50(1x,i2,f5.2))') &
22283          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22284          j=1,num_cont_hb(i))
22285         enddo
22286       endif
22287       ecorr=0.0D0
22288       ecorr3=0.0d0
22289 !C Remove the loop below after debugging !!!
22290 !      do i=nnt_molec(2),nct_molec(2)
22291 !        do j=1,3
22292 !          gradcorr_nucl(j,i)=0.0D0
22293 !          gradxorr_nucl(j,i)=0.0D0
22294 !          gradcorr3_nucl(j,i)=0.0D0
22295 !          gradxorr3_nucl(j,i)=0.0D0
22296 !        enddo
22297 !      enddo
22298 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22299 !C Calculate the local-electrostatic correlation terms
22300       do i=iatsc_s_nucl,iatsc_e_nucl
22301         i1=i+1
22302         num_conti=num_cont_hb(i)
22303         num_conti1=num_cont_hb(i+1)
22304 !        print *,i,num_conti,num_conti1
22305         do jj=1,num_conti
22306           j=jcont_hb(jj,i)
22307           do kk=1,num_conti1
22308             j1=jcont_hb(kk,i1)
22309 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22310 !c     &         ' jj=',jj,' kk=',kk
22311             if (j1.eq.j+1 .or. j1.eq.j-1) then
22312 !C
22313 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22314 !C The system gains extra energy.
22315 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22316 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22317 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22318 !C
22319               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22320               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22321                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22322               n_corr=n_corr+1
22323             else if (j1.eq.j) then
22324 !C
22325 !C Contacts I-J and I-(J+1) occur simultaneously.
22326 !C The system loses extra energy.
22327 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22328 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22329 !C Need to implement full formulas 32 from Liwo et al., 1998.
22330 !C
22331 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22332 !c     &         ' jj=',jj,' kk=',kk
22333               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22334             endif
22335           enddo ! kk
22336           do kk=1,num_conti
22337             j1=jcont_hb(kk,i)
22338 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22339 !c     &         ' jj=',jj,' kk=',kk
22340             if (j1.eq.j+1) then
22341 !C Contacts I-J and (I+1)-J occur simultaneously.
22342 !C The system loses extra energy.
22343               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22344             endif ! j1==j+1
22345           enddo ! kk
22346         enddo ! jj
22347       enddo ! i
22348       return
22349       end subroutine multibody_hb_nucl
22350 !-----------------------------------------------------------
22351       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22352 !      implicit real*8 (a-h,o-z)
22353 !      include 'DIMENSIONS'
22354 !      include 'COMMON.IOUNITS'
22355 !      include 'COMMON.DERIV'
22356 !      include 'COMMON.INTERACT'
22357 !      include 'COMMON.CONTACTS'
22358       real(kind=8),dimension(3) :: gx,gx1
22359       logical :: lprn
22360 !el local variables
22361       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22362       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22363                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22364                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22365                    rlocshield
22366
22367       lprn=.false.
22368       eij=facont_hb(jj,i)
22369       ekl=facont_hb(kk,k)
22370       ees0pij=ees0p(jj,i)
22371       ees0pkl=ees0p(kk,k)
22372       ees0mij=ees0m(jj,i)
22373       ees0mkl=ees0m(kk,k)
22374       ekont=eij*ekl
22375       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22376 !      print *,"ehbcorr_nucl",ekont,ees
22377 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22378 !C Following 4 lines for diagnostics.
22379 !cd    ees0pkl=0.0D0
22380 !cd    ees0pij=1.0D0
22381 !cd    ees0mkl=0.0D0
22382 !cd    ees0mij=1.0D0
22383 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22384 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22385 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22386 !C Calculate the multi-body contribution to energy.
22387 !      ecorr_nucl=ecorr_nucl+ekont*ees
22388 !C Calculate multi-body contributions to the gradient.
22389       coeffpees0pij=coeffp*ees0pij
22390       coeffmees0mij=coeffm*ees0mij
22391       coeffpees0pkl=coeffp*ees0pkl
22392       coeffmees0mkl=coeffm*ees0mkl
22393       do ll=1,3
22394         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22395        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22396        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22397         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22398         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22399         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22400         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22401         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22402         coeffmees0mij*gacontm_hb1(ll,kk,k))
22403         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22404         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22405         coeffmees0mij*gacontm_hb2(ll,kk,k))
22406         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22407           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22408           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22409         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22410         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22411         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22412           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22413           coeffmees0mij*gacontm_hb3(ll,kk,k))
22414         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22415         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22416         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22417         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22418         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22419         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22420       enddo
22421       ehbcorr_nucl=ekont*ees
22422       return
22423       end function ehbcorr_nucl
22424 !-------------------------------------------------------------------------
22425
22426      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22427 !      implicit real*8 (a-h,o-z)
22428 !      include 'DIMENSIONS'
22429 !      include 'COMMON.IOUNITS'
22430 !      include 'COMMON.DERIV'
22431 !      include 'COMMON.INTERACT'
22432 !      include 'COMMON.CONTACTS'
22433       real(kind=8),dimension(3) :: gx,gx1
22434       logical :: lprn
22435 !el local variables
22436       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22437       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22438                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22439                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22440                    rlocshield
22441
22442       lprn=.false.
22443       eij=facont_hb(jj,i)
22444       ekl=facont_hb(kk,k)
22445       ees0pij=ees0p(jj,i)
22446       ees0pkl=ees0p(kk,k)
22447       ees0mij=ees0m(jj,i)
22448       ees0mkl=ees0m(kk,k)
22449       ekont=eij*ekl
22450       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22451 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22452 !C Following 4 lines for diagnostics.
22453 !cd    ees0pkl=0.0D0
22454 !cd    ees0pij=1.0D0
22455 !cd    ees0mkl=0.0D0
22456 !cd    ees0mij=1.0D0
22457 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22458 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22459 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22460 !C Calculate the multi-body contribution to energy.
22461 !      ecorr=ecorr+ekont*ees
22462 !C Calculate multi-body contributions to the gradient.
22463       coeffpees0pij=coeffp*ees0pij
22464       coeffmees0mij=coeffm*ees0mij
22465       coeffpees0pkl=coeffp*ees0pkl
22466       coeffmees0mkl=coeffm*ees0mkl
22467       do ll=1,3
22468         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22469        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22470        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22471         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22472         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22473         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22474         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22475         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22476         coeffmees0mij*gacontm_hb1(ll,kk,k))
22477         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22478         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22479         coeffmees0mij*gacontm_hb2(ll,kk,k))
22480         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22481           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22482           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22483         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22484         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22485         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22486           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22487           coeffmees0mij*gacontm_hb3(ll,kk,k))
22488         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22489         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22490         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22491         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22492         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22493         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22494       enddo
22495       ehbcorr3_nucl=ekont*ees
22496       return
22497       end function ehbcorr3_nucl
22498 #ifdef MPI
22499       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22500       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22501       real(kind=8):: buffer(dimen1,dimen2)
22502       num_kont=num_cont_hb(atom)
22503       do i=1,num_kont
22504         do k=1,8
22505           do j=1,3
22506             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22507           enddo ! j
22508         enddo ! k
22509         buffer(i,indx+25)=facont_hb(i,atom)
22510         buffer(i,indx+26)=ees0p(i,atom)
22511         buffer(i,indx+27)=ees0m(i,atom)
22512         buffer(i,indx+28)=d_cont(i,atom)
22513         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22514       enddo ! i
22515       buffer(1,indx+30)=dfloat(num_kont)
22516       return
22517       end subroutine pack_buffer
22518 !c------------------------------------------------------------------------------
22519       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22520       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22521       real(kind=8):: buffer(dimen1,dimen2)
22522 !      double precision zapas
22523 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22524 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22525 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22526 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22527       num_kont=buffer(1,indx+30)
22528       num_kont_old=num_cont_hb(atom)
22529       num_cont_hb(atom)=num_kont+num_kont_old
22530       do i=1,num_kont
22531         ii=i+num_kont_old
22532         do k=1,8
22533           do j=1,3
22534             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22535           enddo ! j
22536         enddo ! k
22537         facont_hb(ii,atom)=buffer(i,indx+25)
22538         ees0p(ii,atom)=buffer(i,indx+26)
22539         ees0m(ii,atom)=buffer(i,indx+27)
22540         d_cont(i,atom)=buffer(i,indx+28)
22541         jcont_hb(ii,atom)=buffer(i,indx+29)
22542       enddo ! i
22543       return
22544       end subroutine unpack_buffer
22545 !c------------------------------------------------------------------------------
22546 #endif
22547       subroutine ecatcat(ecationcation)
22548         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
22549         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22550         r7,r4,ecationcation,k0,rcal
22551         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22552         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22553         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22554         gg,r
22555
22556         ecationcation=0.0d0
22557         if (nres_molec(5).eq.0) return
22558         rcat0=3.472
22559         epscalc=0.05
22560         r06 = rcat0**6
22561         r012 = r06**2
22562         k0 = 332.0*(2.0*2.0)/80.0
22563         itmp=0
22564
22565         do i=1,4
22566         itmp=itmp+nres_molec(i)
22567         enddo
22568 !        write(iout,*) "itmp",itmp
22569         do i=itmp+1,itmp+nres_molec(5)-1
22570
22571         xi=c(1,i)
22572         yi=c(2,i)
22573         zi=c(3,i)
22574
22575           xi=mod(xi,boxxsize)
22576           if (xi.lt.0) xi=xi+boxxsize
22577           yi=mod(yi,boxysize)
22578           if (yi.lt.0) yi=yi+boxysize
22579           zi=mod(zi,boxzsize)
22580           if (zi.lt.0) zi=zi+boxzsize
22581
22582           do j=i+1,itmp+nres_molec(5)
22583 !           print *,i,j,'catcat'
22584            xj=c(1,j)
22585            yj=c(2,j)
22586            zj=c(3,j)
22587           xj=dmod(xj,boxxsize)
22588           if (xj.lt.0) xj=xj+boxxsize
22589           yj=dmod(yj,boxysize)
22590           if (yj.lt.0) yj=yj+boxysize
22591           zj=dmod(zj,boxzsize)
22592           if (zj.lt.0) zj=zj+boxzsize
22593 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22594       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22595       xj_safe=xj
22596       yj_safe=yj
22597       zj_safe=zj
22598       subchap=0
22599       do xshift=-1,1
22600       do yshift=-1,1
22601       do zshift=-1,1
22602           xj=xj_safe+xshift*boxxsize
22603           yj=yj_safe+yshift*boxysize
22604           zj=zj_safe+zshift*boxzsize
22605           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22606           if(dist_temp.lt.dist_init) then
22607             dist_init=dist_temp
22608             xj_temp=xj
22609             yj_temp=yj
22610             zj_temp=zj
22611             subchap=1
22612           endif
22613        enddo
22614        enddo
22615        enddo
22616        if (subchap.eq.1) then
22617           xj=xj_temp-xi
22618           yj=yj_temp-yi
22619           zj=zj_temp-zi
22620        else
22621           xj=xj_safe-xi
22622           yj=yj_safe-yi
22623           zj=zj_safe-zi
22624        endif
22625        rcal =xj**2+yj**2+zj**2
22626         ract=sqrt(rcal)
22627 !        rcat0=3.472
22628 !        epscalc=0.05
22629 !        r06 = rcat0**6
22630 !        r012 = r06**2
22631 !        k0 = 332*(2*2)/80
22632         Evan1cat=epscalc*(r012/rcal**6)
22633         Evan2cat=epscalc*2*(r06/rcal**3)
22634         Eeleccat=k0/ract
22635         r7 = rcal**7
22636         r4 = rcal**4
22637         r(1)=xj
22638         r(2)=yj
22639         r(3)=zj
22640         do k=1,3
22641           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22642           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22643           dEeleccat(k)=-k0*r(k)/ract**3
22644         enddo
22645         do k=1,3
22646           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22647           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22648           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22649         enddo
22650
22651 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22652         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22653        enddo
22654        enddo
22655        return
22656        end subroutine ecatcat
22657 !---------------------------------------------------------------------------
22658        subroutine ecat_prot(ecation_prot)
22659        integer i,j,k,subchap,itmp,inum
22660         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22661         r7,r4,ecationcation
22662         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22663         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22664         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22665         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22666         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22667         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22668         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22669         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22670         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22671         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22672         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22673         ndiv,ndivi
22674         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22675         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22676         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22677         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22678         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22679         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22680         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22681         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22682         dEvan1Cat
22683         real(kind=8),dimension(6) :: vcatprm
22684         ecation_prot=0.0d0
22685 ! first lets calculate interaction with peptide groups
22686         if (nres_molec(5).eq.0) return
22687         itmp=0
22688         do i=1,4
22689         itmp=itmp+nres_molec(i)
22690         enddo
22691 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22692         do i=ibond_start,ibond_end
22693 !         cycle
22694          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22695         xi=0.5d0*(c(1,i)+c(1,i+1))
22696         yi=0.5d0*(c(2,i)+c(2,i+1))
22697         zi=0.5d0*(c(3,i)+c(3,i+1))
22698           xi=mod(xi,boxxsize)
22699           if (xi.lt.0) xi=xi+boxxsize
22700           yi=mod(yi,boxysize)
22701           if (yi.lt.0) yi=yi+boxysize
22702           zi=mod(zi,boxzsize)
22703           if (zi.lt.0) zi=zi+boxzsize
22704
22705          do j=itmp+1,itmp+nres_molec(5)
22706 !           print *,"WTF",itmp,j,i
22707 ! all parameters were for Ca2+ to approximate single charge divide by two
22708          ndiv=1.0
22709          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22710          wconst=78*ndiv
22711         wdip =1.092777950857032D2
22712         wdip=wdip/wconst
22713         wmodquad=-2.174122713004870D4
22714         wmodquad=wmodquad/wconst
22715         wquad1 = 3.901232068562804D1
22716         wquad1=wquad1/wconst
22717         wquad2 = 3
22718         wquad2=wquad2/wconst
22719         wvan1 = 0.1
22720         wvan2 = 6
22721 !        itmp=0
22722
22723            xj=c(1,j)
22724            yj=c(2,j)
22725            zj=c(3,j)
22726           xj=dmod(xj,boxxsize)
22727           if (xj.lt.0) xj=xj+boxxsize
22728           yj=dmod(yj,boxysize)
22729           if (yj.lt.0) yj=yj+boxysize
22730           zj=dmod(zj,boxzsize)
22731           if (zj.lt.0) zj=zj+boxzsize
22732       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22733       xj_safe=xj
22734       yj_safe=yj
22735       zj_safe=zj
22736       subchap=0
22737       do xshift=-1,1
22738       do yshift=-1,1
22739       do zshift=-1,1
22740           xj=xj_safe+xshift*boxxsize
22741           yj=yj_safe+yshift*boxysize
22742           zj=zj_safe+zshift*boxzsize
22743           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22744           if(dist_temp.lt.dist_init) then
22745             dist_init=dist_temp
22746             xj_temp=xj
22747             yj_temp=yj
22748             zj_temp=zj
22749             subchap=1
22750           endif
22751        enddo
22752        enddo
22753        enddo
22754        if (subchap.eq.1) then
22755           xj=xj_temp-xi
22756           yj=yj_temp-yi
22757           zj=zj_temp-zi
22758        else
22759           xj=xj_safe-xi
22760           yj=yj_safe-yi
22761           zj=zj_safe-zi
22762        endif
22763 !       enddo
22764 !       enddo
22765        rcpm = sqrt(xj**2+yj**2+zj**2)
22766        drcp_norm(1)=xj/rcpm
22767        drcp_norm(2)=yj/rcpm
22768        drcp_norm(3)=zj/rcpm
22769        dcmag=0.0
22770        do k=1,3
22771        dcmag=dcmag+dc(k,i)**2
22772        enddo
22773        dcmag=dsqrt(dcmag)
22774        do k=1,3
22775          myd_norm(k)=dc(k,i)/dcmag
22776        enddo
22777         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22778         drcp_norm(3)*myd_norm(3)
22779         rsecp = rcpm**2
22780         Ir = 1.0d0/rcpm
22781         Irsecp = 1.0d0/rsecp
22782         Irthrp = Irsecp/rcpm
22783         Irfourp = Irthrp/rcpm
22784         Irfiftp = Irfourp/rcpm
22785         Irsistp=Irfiftp/rcpm
22786         Irseven=Irsistp/rcpm
22787         Irtwelv=Irsistp*Irsistp
22788         Irthir=Irtwelv/rcpm
22789         sin2thet = (1-costhet*costhet)
22790         sinthet=sqrt(sin2thet)
22791         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22792              *sin2thet
22793         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22794              2*wvan2**6*Irsistp)
22795         ecation_prot = ecation_prot+E1+E2
22796 !        print *,"ecatprot",i,j,ecation_prot,rcpm
22797         dE1dr = -2*costhet*wdip*Irthrp-&
22798          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22799         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22800           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22801         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22802         do k=1,3
22803           drdpep(k) = -drcp_norm(k)
22804           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22805           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22806           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22807           dEddci(k) = dEdcos*dcosddci(k)
22808         enddo
22809         do k=1,3
22810         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22811         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22812         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22813         enddo
22814        enddo ! j
22815        enddo ! i
22816 !------------------------------------------sidechains
22817 !        do i=1,nres_molec(1)
22818         do i=ibond_start,ibond_end
22819          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22820 !         cycle
22821 !        print *,i,ecation_prot
22822         xi=(c(1,i+nres))
22823         yi=(c(2,i+nres))
22824         zi=(c(3,i+nres))
22825           xi=mod(xi,boxxsize)
22826           if (xi.lt.0) xi=xi+boxxsize
22827           yi=mod(yi,boxysize)
22828           if (yi.lt.0) yi=yi+boxysize
22829           zi=mod(zi,boxzsize)
22830           if (zi.lt.0) zi=zi+boxzsize
22831           do k=1,3
22832             cm1(k)=dc(k,i+nres)
22833           enddo
22834            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22835          do j=itmp+1,itmp+nres_molec(5)
22836          ndiv=1.0
22837          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22838
22839            xj=c(1,j)
22840            yj=c(2,j)
22841            zj=c(3,j)
22842           xj=dmod(xj,boxxsize)
22843           if (xj.lt.0) xj=xj+boxxsize
22844           yj=dmod(yj,boxysize)
22845           if (yj.lt.0) yj=yj+boxysize
22846           zj=dmod(zj,boxzsize)
22847           if (zj.lt.0) zj=zj+boxzsize
22848       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22849       xj_safe=xj
22850       yj_safe=yj
22851       zj_safe=zj
22852       subchap=0
22853       do xshift=-1,1
22854       do yshift=-1,1
22855       do zshift=-1,1
22856           xj=xj_safe+xshift*boxxsize
22857           yj=yj_safe+yshift*boxysize
22858           zj=zj_safe+zshift*boxzsize
22859           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22860           if(dist_temp.lt.dist_init) then
22861             dist_init=dist_temp
22862             xj_temp=xj
22863             yj_temp=yj
22864             zj_temp=zj
22865             subchap=1
22866           endif
22867        enddo
22868        enddo
22869        enddo
22870        if (subchap.eq.1) then
22871           xj=xj_temp-xi
22872           yj=yj_temp-yi
22873           zj=zj_temp-zi
22874        else
22875           xj=xj_safe-xi
22876           yj=yj_safe-yi
22877           zj=zj_safe-zi
22878        endif
22879 !       enddo
22880 !       enddo
22881 ! 15- Glu 16-Asp
22882          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
22883          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
22884          (itype(i,1).eq.25))) then
22885             if(itype(i,1).eq.16) then
22886             inum=1
22887             else
22888             inum=2
22889             endif
22890             do k=1,6
22891             vcatprm(k)=catprm(k,inum)
22892             enddo
22893             dASGL=catprm(7,inum)
22894 !             do k=1,3
22895 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22896                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
22897                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
22898                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
22899
22900 !                valpha(k)=c(k,i)
22901 !                vcat(k)=c(k,j)
22902                 if (subchap.eq.1) then
22903                  vcat(1)=xj_temp
22904                  vcat(2)=yj_temp
22905                  vcat(3)=zj_temp
22906                  else
22907                 vcat(1)=xj_safe
22908                 vcat(2)=yj_safe
22909                 vcat(3)=zj_safe
22910                  endif
22911                 valpha(1)=xi-c(1,i+nres)+c(1,i)
22912                 valpha(2)=yi-c(2,i+nres)+c(2,i)
22913                 valpha(3)=zi-c(3,i+nres)+c(3,i)
22914
22915 !              enddo
22916         do k=1,3
22917           dx(k) = vcat(k)-vcm(k)
22918         enddo
22919         do k=1,3
22920           v1(k)=(vcm(k)-valpha(k))
22921           v2(k)=(vcat(k)-valpha(k))
22922         enddo
22923         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22924         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22925         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22926
22927 !  The weights of the energy function calculated from
22928 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22929           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22930             ndivi=0.5
22931           else
22932             ndivi=1.0
22933           endif
22934          ndiv=1.0
22935          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22936
22937         wh2o=78*ndivi*ndiv
22938         wc = vcatprm(1)
22939         wc=wc/wh2o
22940         wdip =vcatprm(2)
22941         wdip=wdip/wh2o
22942         wquad1 =vcatprm(3)
22943         wquad1=wquad1/wh2o
22944         wquad2 = vcatprm(4)
22945         wquad2=wquad2/wh2o
22946         wquad2p = 1.0d0-wquad2
22947         wvan1 = vcatprm(5)
22948         wvan2 =vcatprm(6)
22949         opt = dx(1)**2+dx(2)**2
22950         rsecp = opt+dx(3)**2
22951         rs = sqrt(rsecp)
22952         rthrp = rsecp*rs
22953         rfourp = rthrp*rs
22954         rsixp = rfourp*rsecp
22955         reight=rsixp*rsecp
22956         Ir = 1.0d0/rs
22957         Irsecp = 1.0d0/rsecp
22958         Irthrp = Irsecp/rs
22959         Irfourp = Irthrp/rs
22960         Irsixp = 1.0d0/rsixp
22961         Ireight=1.0d0/reight
22962         Irtw=Irsixp*Irsixp
22963         Irthir=Irtw/rs
22964         Irfourt=Irthir/rs
22965         opt1 = (4*rs*dx(3)*wdip)
22966         opt2 = 6*rsecp*wquad1*opt
22967         opt3 = wquad1*wquad2p*Irsixp
22968         opt4 = (wvan1*wvan2**12)
22969         opt5 = opt4*12*Irfourt
22970         opt6 = 2*wvan1*wvan2**6
22971         opt7 = 6*opt6*Ireight
22972         opt8 = wdip/v1m
22973         opt10 = wdip/v2m
22974         opt11 = (rsecp*v2m)**2
22975         opt12 = (rsecp*v1m)**2
22976         opt14 = (v1m*v2m*rsecp)**2
22977         opt15 = -wquad1/v2m**2
22978         opt16 = (rthrp*(v1m*v2m)**2)**2
22979         opt17 = (v1m**2*rthrp)**2
22980         opt18 = -wquad1/rthrp
22981         opt19 = (v1m**2*v2m**2)**2
22982         Ec = wc*Ir
22983         do k=1,3
22984           dEcCat(k) = -(dx(k)*wc)*Irthrp
22985           dEcCm(k)=(dx(k)*wc)*Irthrp
22986           dEcCalp(k)=0.0d0
22987         enddo
22988         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22989         do k=1,3
22990           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22991                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22992           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22993                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22994           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22995                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22996                       *v1dpv2)/opt14
22997         enddo
22998         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22999         do k=1,3
23000           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23001                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23002                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23003           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23004                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23005                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23006           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23007                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23008                         v1dpv2**2)/opt19
23009         enddo
23010         Equad2=wquad1*wquad2p*Irthrp
23011         do k=1,3
23012           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23013           dEquad2Cm(k)=3*dx(k)*rs*opt3
23014           dEquad2Calp(k)=0.0d0
23015         enddo
23016         Evan1=opt4*Irtw
23017         do k=1,3
23018           dEvan1Cat(k)=-dx(k)*opt5
23019           dEvan1Cm(k)=dx(k)*opt5
23020           dEvan1Calp(k)=0.0d0
23021         enddo
23022         Evan2=-opt6*Irsixp
23023         do k=1,3
23024           dEvan2Cat(k)=dx(k)*opt7
23025           dEvan2Cm(k)=-dx(k)*opt7
23026           dEvan2Calp(k)=0.0d0
23027         enddo
23028         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23029 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23030
23031         do k=1,3
23032           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23033                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23034 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23035           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23036                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23037           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23038                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23039         enddo
23040             dscmag = 0.0d0
23041             do k=1,3
23042               dscvec(k) = dc(k,i+nres)
23043               dscmag = dscmag+dscvec(k)*dscvec(k)
23044             enddo
23045             dscmag3 = dscmag
23046             dscmag = sqrt(dscmag)
23047             dscmag3 = dscmag3*dscmag
23048             constA = 1.0d0+dASGL/dscmag
23049             constB = 0.0d0
23050             do k=1,3
23051               constB = constB+dscvec(k)*dEtotalCm(k)
23052             enddo
23053             constB = constB*dASGL/dscmag3
23054             do k=1,3
23055               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23056               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23057                constA*dEtotalCm(k)-constB*dscvec(k)
23058 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23059               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23060               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23061              enddo
23062         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23063            if(itype(i,1).eq.14) then
23064             inum=3
23065             else
23066             inum=4
23067             endif
23068             do k=1,6
23069             vcatprm(k)=catprm(k,inum)
23070             enddo
23071             dASGL=catprm(7,inum)
23072 !             do k=1,3
23073 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23074 !                valpha(k)=c(k,i)
23075 !                vcat(k)=c(k,j)
23076 !              enddo
23077                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23078                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23079                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23080                 if (subchap.eq.1) then
23081                  vcat(1)=xj_temp
23082                  vcat(2)=yj_temp
23083                  vcat(3)=zj_temp
23084                  else
23085                 vcat(1)=xj_safe
23086                 vcat(2)=yj_safe
23087                 vcat(3)=zj_safe
23088                 endif
23089                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23090                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23091                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23092
23093
23094         do k=1,3
23095           dx(k) = vcat(k)-vcm(k)
23096         enddo
23097         do k=1,3
23098           v1(k)=(vcm(k)-valpha(k))
23099           v2(k)=(vcat(k)-valpha(k))
23100         enddo
23101         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23102         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23103         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23104 !  The weights of the energy function calculated from
23105 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23106          ndiv=1.0
23107          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23108
23109         wh2o=78*ndiv
23110         wdip =vcatprm(2)
23111         wdip=wdip/wh2o
23112         wquad1 =vcatprm(3)
23113         wquad1=wquad1/wh2o
23114         wquad2 = vcatprm(4)
23115         wquad2=wquad2/wh2o
23116         wquad2p = 1-wquad2
23117         wvan1 = vcatprm(5)
23118         wvan2 =vcatprm(6)
23119         opt = dx(1)**2+dx(2)**2
23120         rsecp = opt+dx(3)**2
23121         rs = sqrt(rsecp)
23122         rthrp = rsecp*rs
23123         rfourp = rthrp*rs
23124         rsixp = rfourp*rsecp
23125         reight=rsixp*rsecp
23126         Ir = 1.0d0/rs
23127         Irsecp = 1/rsecp
23128         Irthrp = Irsecp/rs
23129         Irfourp = Irthrp/rs
23130         Irsixp = 1/rsixp
23131         Ireight=1/reight
23132         Irtw=Irsixp*Irsixp
23133         Irthir=Irtw/rs
23134         Irfourt=Irthir/rs
23135         opt1 = (4*rs*dx(3)*wdip)
23136         opt2 = 6*rsecp*wquad1*opt
23137         opt3 = wquad1*wquad2p*Irsixp
23138         opt4 = (wvan1*wvan2**12)
23139         opt5 = opt4*12*Irfourt
23140         opt6 = 2*wvan1*wvan2**6
23141         opt7 = 6*opt6*Ireight
23142         opt8 = wdip/v1m
23143         opt10 = wdip/v2m
23144         opt11 = (rsecp*v2m)**2
23145         opt12 = (rsecp*v1m)**2
23146         opt14 = (v1m*v2m*rsecp)**2
23147         opt15 = -wquad1/v2m**2
23148         opt16 = (rthrp*(v1m*v2m)**2)**2
23149         opt17 = (v1m**2*rthrp)**2
23150         opt18 = -wquad1/rthrp
23151         opt19 = (v1m**2*v2m**2)**2
23152         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23153         do k=1,3
23154           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23155                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23156          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23157                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23158           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23159                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23160                       *v1dpv2)/opt14
23161         enddo
23162         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23163         do k=1,3
23164           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23165                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23166                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23167           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23168                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23169                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23170           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23171                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23172                         v1dpv2**2)/opt19
23173         enddo
23174         Equad2=wquad1*wquad2p*Irthrp
23175         do k=1,3
23176           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23177           dEquad2Cm(k)=3*dx(k)*rs*opt3
23178           dEquad2Calp(k)=0.0d0
23179         enddo
23180         Evan1=opt4*Irtw
23181         do k=1,3
23182           dEvan1Cat(k)=-dx(k)*opt5
23183           dEvan1Cm(k)=dx(k)*opt5
23184           dEvan1Calp(k)=0.0d0
23185         enddo
23186         Evan2=-opt6*Irsixp
23187         do k=1,3
23188           dEvan2Cat(k)=dx(k)*opt7
23189           dEvan2Cm(k)=-dx(k)*opt7
23190           dEvan2Calp(k)=0.0d0
23191         enddo
23192          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23193         do k=1,3
23194           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23195                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23196           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23197                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23198           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23199                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23200         enddo
23201             dscmag = 0.0d0
23202             do k=1,3
23203               dscvec(k) = c(k,i+nres)-c(k,i)
23204 ! TU SPRAWDZ???
23205 !              dscvec(1) = xj
23206 !              dscvec(2) = yj
23207 !              dscvec(3) = zj
23208
23209               dscmag = dscmag+dscvec(k)*dscvec(k)
23210             enddo
23211             dscmag3 = dscmag
23212             dscmag = sqrt(dscmag)
23213             dscmag3 = dscmag3*dscmag
23214             constA = 1+dASGL/dscmag
23215             constB = 0.0d0
23216             do k=1,3
23217               constB = constB+dscvec(k)*dEtotalCm(k)
23218             enddo
23219             constB = constB*dASGL/dscmag3
23220             do k=1,3
23221               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23222               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23223                constA*dEtotalCm(k)-constB*dscvec(k)
23224               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23225               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23226              enddo
23227            else
23228             rcal = 0.0d0
23229             do k=1,3
23230 !              r(k) = c(k,j)-c(k,i+nres)
23231               r(1) = xj
23232               r(2) = yj
23233               r(3) = zj
23234               rcal = rcal+r(k)*r(k)
23235             enddo
23236             ract=sqrt(rcal)
23237             rocal=1.5
23238             epscalc=0.2
23239             r0p=0.5*(rocal+sig0(itype(i,1)))
23240             r06 = r0p**6
23241             r012 = r06*r06
23242             Evan1=epscalc*(r012/rcal**6)
23243             Evan2=epscalc*2*(r06/rcal**3)
23244             r4 = rcal**4
23245             r7 = rcal**7
23246             do k=1,3
23247               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23248               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23249             enddo
23250             do k=1,3
23251               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23252             enddo
23253                  ecation_prot = ecation_prot+ Evan1+Evan2
23254             do  k=1,3
23255                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23256                dEtotalCm(k)
23257               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23258               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23259              enddo
23260          endif ! 13-16 residues
23261        enddo !j
23262        enddo !i
23263        return
23264        end subroutine ecat_prot
23265
23266 !----------------------------------------------------------------------------
23267 !-----------------------------------------------------------------------------
23268 !-----------------------------------------------------------------------------
23269       subroutine eprot_sc_base(escbase)
23270       use calc_data
23271 !      implicit real*8 (a-h,o-z)
23272 !      include 'DIMENSIONS'
23273 !      include 'COMMON.GEO'
23274 !      include 'COMMON.VAR'
23275 !      include 'COMMON.LOCAL'
23276 !      include 'COMMON.CHAIN'
23277 !      include 'COMMON.DERIV'
23278 !      include 'COMMON.NAMES'
23279 !      include 'COMMON.INTERACT'
23280 !      include 'COMMON.IOUNITS'
23281 !      include 'COMMON.CALC'
23282 !      include 'COMMON.CONTROL'
23283 !      include 'COMMON.SBRIDGE'
23284       logical :: lprn
23285 !el local variables
23286       integer :: iint,itypi,itypi1,itypj,subchap
23287       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23288       real(kind=8) :: evdw,sig0ij
23289       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23290                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23291                     sslipi,sslipj,faclip
23292       integer :: ii
23293       real(kind=8) :: fracinbuf
23294        real (kind=8) :: escbase
23295        real (kind=8),dimension(4):: ener
23296        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23297        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23298         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23299         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23300         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23301         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23302         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23303         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23304        real(kind=8),dimension(3,2)::chead,erhead_tail
23305        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23306        integer troll
23307        eps_out=80.0d0
23308        escbase=0.0d0
23309 !       do i=1,nres_molec(1)
23310         do i=ibond_start,ibond_end
23311         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23312         itypi  = itype(i,1)
23313         dxi    = dc_norm(1,nres+i)
23314         dyi    = dc_norm(2,nres+i)
23315         dzi    = dc_norm(3,nres+i)
23316         dsci_inv = vbld_inv(i+nres)
23317         xi=c(1,nres+i)
23318         yi=c(2,nres+i)
23319         zi=c(3,nres+i)
23320         xi=mod(xi,boxxsize)
23321          if (xi.lt.0) xi=xi+boxxsize
23322         yi=mod(yi,boxysize)
23323          if (yi.lt.0) yi=yi+boxysize
23324         zi=mod(zi,boxzsize)
23325          if (zi.lt.0) zi=zi+boxzsize
23326          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23327            itypj= itype(j,2)
23328            if (itype(j,2).eq.ntyp1_molec(2))cycle
23329            xj=c(1,j+nres)
23330            yj=c(2,j+nres)
23331            zj=c(3,j+nres)
23332            xj=dmod(xj,boxxsize)
23333            if (xj.lt.0) xj=xj+boxxsize
23334            yj=dmod(yj,boxysize)
23335            if (yj.lt.0) yj=yj+boxysize
23336            zj=dmod(zj,boxzsize)
23337            if (zj.lt.0) zj=zj+boxzsize
23338           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23339           xj_safe=xj
23340           yj_safe=yj
23341           zj_safe=zj
23342           subchap=0
23343
23344           do xshift=-1,1
23345           do yshift=-1,1
23346           do zshift=-1,1
23347           xj=xj_safe+xshift*boxxsize
23348           yj=yj_safe+yshift*boxysize
23349           zj=zj_safe+zshift*boxzsize
23350           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23351           if(dist_temp.lt.dist_init) then
23352             dist_init=dist_temp
23353             xj_temp=xj
23354             yj_temp=yj
23355             zj_temp=zj
23356             subchap=1
23357           endif
23358           enddo
23359           enddo
23360           enddo
23361           if (subchap.eq.1) then
23362           xj=xj_temp-xi
23363           yj=yj_temp-yi
23364           zj=zj_temp-zi
23365           else
23366           xj=xj_safe-xi
23367           yj=yj_safe-yi
23368           zj=zj_safe-zi
23369           endif
23370           dxj = dc_norm( 1, nres+j )
23371           dyj = dc_norm( 2, nres+j )
23372           dzj = dc_norm( 3, nres+j )
23373 !          print *,i,j,itypi,itypj
23374           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23375           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23376 !          d1i=0.0d0
23377 !          d1j=0.0d0
23378 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23379 ! Gay-berne var's
23380           sig0ij = sigma_scbase( itypi,itypj )
23381           chi1   = chi_scbase( itypi, itypj,1 )
23382           chi2   = chi_scbase( itypi, itypj,2 )
23383 !          chi1=0.0d0
23384 !          chi2=0.0d0
23385           chi12  = chi1 * chi2
23386           chip1  = chipp_scbase( itypi, itypj,1 )
23387           chip2  = chipp_scbase( itypi, itypj,2 )
23388 !          chip1=0.0d0
23389 !          chip2=0.0d0
23390           chip12 = chip1 * chip2
23391 ! not used by momo potential, but needed by sc_angular which is shared
23392 ! by all energy_potential subroutines
23393           alf1   = 0.0d0
23394           alf2   = 0.0d0
23395           alf12  = 0.0d0
23396           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23397 !       a12sq = a12sq * a12sq
23398 ! charge of amino acid itypi is...
23399           chis1 = chis_scbase(itypi,itypj,1)
23400           chis2 = chis_scbase(itypi,itypj,2)
23401           chis12 = chis1 * chis2
23402           sig1 = sigmap1_scbase(itypi,itypj)
23403           sig2 = sigmap2_scbase(itypi,itypj)
23404 !       write (*,*) "sig1 = ", sig1
23405 !       write (*,*) "sig2 = ", sig2
23406 ! alpha factors from Fcav/Gcav
23407           b1 = alphasur_scbase(1,itypi,itypj)
23408 !          b1=0.0d0
23409           b2 = alphasur_scbase(2,itypi,itypj)
23410           b3 = alphasur_scbase(3,itypi,itypj)
23411           b4 = alphasur_scbase(4,itypi,itypj)
23412 ! used to determine whether we want to do quadrupole calculations
23413 ! used by Fgb
23414        eps_in = epsintab_scbase(itypi,itypj)
23415        if (eps_in.eq.0.0) eps_in=1.0
23416        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23417 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23418 !-------------------------------------------------------------------
23419 ! tail location and distance calculations
23420        DO k = 1,3
23421 ! location of polar head is computed by taking hydrophobic centre
23422 ! and moving by a d1 * dc_norm vector
23423 ! see unres publications for very informative images
23424         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23425         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23426 ! distance
23427 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23428 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23429         Rhead_distance(k) = chead(k,2) - chead(k,1)
23430        END DO
23431 ! pitagoras (root of sum of squares)
23432        Rhead = dsqrt( &
23433           (Rhead_distance(1)*Rhead_distance(1)) &
23434         + (Rhead_distance(2)*Rhead_distance(2)) &
23435         + (Rhead_distance(3)*Rhead_distance(3)))
23436 !-------------------------------------------------------------------
23437 ! zero everything that should be zero'ed
23438        evdwij = 0.0d0
23439        ECL = 0.0d0
23440        Elj = 0.0d0
23441        Equad = 0.0d0
23442        Epol = 0.0d0
23443        Fcav=0.0d0
23444        eheadtail = 0.0d0
23445        dGCLdOM1 = 0.0d0
23446        dGCLdOM2 = 0.0d0
23447        dGCLdOM12 = 0.0d0
23448        dPOLdOM1 = 0.0d0
23449        dPOLdOM2 = 0.0d0
23450           Fcav = 0.0d0
23451           dFdR = 0.0d0
23452           dCAVdOM1  = 0.0d0
23453           dCAVdOM2  = 0.0d0
23454           dCAVdOM12 = 0.0d0
23455           dscj_inv = vbld_inv(j+nres)
23456 !          print *,i,j,dscj_inv,dsci_inv
23457 ! rij holds 1/(distance of Calpha atoms)
23458           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23459           rij  = dsqrt(rrij)
23460 !----------------------------
23461           CALL sc_angular
23462 ! this should be in elgrad_init but om's are calculated by sc_angular
23463 ! which in turn is used by older potentials
23464 ! om = omega, sqom = om^2
23465           sqom1  = om1 * om1
23466           sqom2  = om2 * om2
23467           sqom12 = om12 * om12
23468
23469 ! now we calculate EGB - Gey-Berne
23470 ! It will be summed up in evdwij and saved in evdw
23471           sigsq     = 1.0D0  / sigsq
23472           sig       = sig0ij * dsqrt(sigsq)
23473 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23474           rij_shift = 1.0/rij - sig + sig0ij
23475           IF (rij_shift.le.0.0D0) THEN
23476            evdw = 1.0D20
23477            RETURN
23478           END IF
23479           sigder = -sig * sigsq
23480           rij_shift = 1.0D0 / rij_shift
23481           fac       = rij_shift**expon
23482           c1        = fac  * fac * aa_scbase(itypi,itypj)
23483 !          c1        = 0.0d0
23484           c2        = fac  * bb_scbase(itypi,itypj)
23485 !          c2        = 0.0d0
23486           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23487           eps2der   = eps3rt * evdwij
23488           eps3der   = eps2rt * evdwij
23489 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23490           evdwij    = eps2rt * eps3rt * evdwij
23491           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23492           fac    = -expon * (c1 + evdwij) * rij_shift
23493           sigder = fac * sigder
23494 !          fac    = rij * fac
23495 ! Calculate distance derivative
23496           gg(1) =  fac
23497           gg(2) =  fac
23498           gg(3) =  fac
23499 !          if (b2.gt.0.0) then
23500           fac = chis1 * sqom1 + chis2 * sqom2 &
23501           - 2.0d0 * chis12 * om1 * om2 * om12
23502 ! we will use pom later in Gcav, so dont mess with it!
23503           pom = 1.0d0 - chis1 * chis2 * sqom12
23504           Lambf = (1.0d0 - (fac / pom))
23505           Lambf = dsqrt(Lambf)
23506           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23507 !       write (*,*) "sparrow = ", sparrow
23508           Chif = 1.0d0/rij * sparrow
23509           ChiLambf = Chif * Lambf
23510           eagle = dsqrt(ChiLambf)
23511           bat = ChiLambf ** 11.0d0
23512           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23513           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23514           botsq = bot * bot
23515           Fcav = top / bot
23516 !          print *,i,j,Fcav
23517           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23518           dbot = 12.0d0 * b4 * bat * Lambf
23519           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23520 !       dFdR = 0.0d0
23521 !      write (*,*) "dFcav/dR = ", dFdR
23522           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23523           dbot = 12.0d0 * b4 * bat * Chif
23524           eagle = Lambf * pom
23525           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23526           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23527           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23528               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23529
23530           dFdL = ((dtop * bot - top * dbot) / botsq)
23531 !       dFdL = 0.0d0
23532           dCAVdOM1  = dFdL * ( dFdOM1 )
23533           dCAVdOM2  = dFdL * ( dFdOM2 )
23534           dCAVdOM12 = dFdL * ( dFdOM12 )
23535
23536           ertail(1) = xj*rij
23537           ertail(2) = yj*rij
23538           ertail(3) = zj*rij
23539 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23540 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23541 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23542 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23543 !           print *,"EOMY",eom1,eom2,eom12
23544 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23545 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23546 ! here dtail=0.0
23547 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23548 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23549        DO k = 1, 3
23550 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23551 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23552         pom = ertail(k)
23553 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23554         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23555                   - (( dFdR + gg(k) ) * pom)
23556 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23557 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23558 !     &             - ( dFdR * pom )
23559         pom = ertail(k)
23560 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23561         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23562                   + (( dFdR + gg(k) ) * pom)
23563 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23564 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23565 !c!     &             + ( dFdR * pom )
23566
23567         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23568                   - (( dFdR + gg(k) ) * ertail(k))
23569 !c!     &             - ( dFdR * ertail(k))
23570
23571         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23572                   + (( dFdR + gg(k) ) * ertail(k))
23573 !c!     &             + ( dFdR * ertail(k))
23574
23575         gg(k) = 0.0d0
23576 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23577 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23578       END DO
23579
23580 !          else
23581
23582 !          endif
23583 !Now dipole-dipole
23584          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23585        w1 = wdipdip_scbase(1,itypi,itypj)
23586        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23587        w3 = wdipdip_scbase(2,itypi,itypj)
23588 !c!-------------------------------------------------------------------
23589 !c! ECL
23590        fac = (om12 - 3.0d0 * om1 * om2)
23591        c1 = (w1 / (Rhead**3.0d0)) * fac
23592        c2 = (w2 / Rhead ** 6.0d0)  &
23593          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23594        c3= (w3/ Rhead ** 6.0d0)  &
23595          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23596        ECL = c1 - c2 + c3
23597 !c!       write (*,*) "w1 = ", w1
23598 !c!       write (*,*) "w2 = ", w2
23599 !c!       write (*,*) "om1 = ", om1
23600 !c!       write (*,*) "om2 = ", om2
23601 !c!       write (*,*) "om12 = ", om12
23602 !c!       write (*,*) "fac = ", fac
23603 !c!       write (*,*) "c1 = ", c1
23604 !c!       write (*,*) "c2 = ", c2
23605 !c!       write (*,*) "Ecl = ", Ecl
23606 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23607 !c!       write (*,*) "c2_2 = ",
23608 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23609 !c!-------------------------------------------------------------------
23610 !c! dervative of ECL is GCL...
23611 !c! dECL/dr
23612        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23613        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23614          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23615        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23616          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23617        dGCLdR = c1 - c2 + c3
23618 !c! dECL/dom1
23619        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23620        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23621          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23622        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23623        dGCLdOM1 = c1 - c2 + c3
23624 !c! dECL/dom2
23625        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23626        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23627          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23628        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23629        dGCLdOM2 = c1 - c2 + c3
23630 !c! dECL/dom12
23631        c1 = w1 / (Rhead ** 3.0d0)
23632        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23633        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23634        dGCLdOM12 = c1 - c2 + c3
23635        DO k= 1, 3
23636         erhead(k) = Rhead_distance(k)/Rhead
23637        END DO
23638        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23639        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23640        facd1 = d1i * vbld_inv(i+nres)
23641        facd2 = d1j * vbld_inv(j+nres)
23642        DO k = 1, 3
23643
23644         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23645         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23646                   - dGCLdR * pom
23647         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23648         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23649                   + dGCLdR * pom
23650
23651         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23652                   - dGCLdR * erhead(k)
23653         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23654                   + dGCLdR * erhead(k)
23655        END DO
23656        endif
23657 !now charge with dipole eg. ARG-dG
23658        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23659       alphapol1 = alphapol_scbase(itypi,itypj)
23660        w1        = wqdip_scbase(1,itypi,itypj)
23661        w2        = wqdip_scbase(2,itypi,itypj)
23662 !       w1=0.0d0
23663 !       w2=0.0d0
23664 !       pis       = sig0head_scbase(itypi,itypj)
23665 !       eps_head   = epshead_scbase(itypi,itypj)
23666 !c!-------------------------------------------------------------------
23667 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23668        R1 = 0.0d0
23669        DO k = 1, 3
23670 !c! Calculate head-to-tail distances tail is center of side-chain
23671         R1=R1+(c(k,j+nres)-chead(k,1))**2
23672        END DO
23673 !c! Pitagoras
23674        R1 = dsqrt(R1)
23675
23676 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23677 !c!     &        +dhead(1,1,itypi,itypj))**2))
23678 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23679 !c!     &        +dhead(2,1,itypi,itypj))**2))
23680
23681 !c!-------------------------------------------------------------------
23682 !c! ecl
23683        sparrow  = w1  *  om1
23684        hawk     = w2 *  (1.0d0 - sqom2)
23685        Ecl = sparrow / Rhead**2.0d0 &
23686            - hawk    / Rhead**4.0d0
23687 !c!-------------------------------------------------------------------
23688 !c! derivative of ecl is Gcl
23689 !c! dF/dr part
23690        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23691                 + 4.0d0 * hawk    / Rhead**5.0d0
23692 !c! dF/dom1
23693        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23694 !c! dF/dom2
23695        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23696 !c--------------------------------------------------------------------
23697 !c Polarization energy
23698 !c Epol
23699        MomoFac1 = (1.0d0 - chi1 * sqom2)
23700        RR1  = R1 * R1 / MomoFac1
23701        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23702        fgb1 = sqrt( RR1 + a12sq * ee1)
23703 !       eps_inout_fac=0.0d0
23704        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23705 ! derivative of Epol is Gpol...
23706        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23707                 / (fgb1 ** 5.0d0)
23708        dFGBdR1 = ( (R1 / MomoFac1) &
23709              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23710              / ( 2.0d0 * fgb1 )
23711        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23712                * (2.0d0 - 0.5d0 * ee1) ) &
23713                / (2.0d0 * fgb1)
23714        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23715 !       dPOLdR1 = 0.0d0
23716        dPOLdOM1 = 0.0d0
23717        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23718        DO k = 1, 3
23719         erhead(k) = Rhead_distance(k)/Rhead
23720         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23721        END DO
23722
23723        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23724        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23725        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23726 !       bat=0.0d0
23727        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23728        facd1 = d1i * vbld_inv(i+nres)
23729        facd2 = d1j * vbld_inv(j+nres)
23730 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23731
23732        DO k = 1, 3
23733         hawk = (erhead_tail(k,1) + &
23734         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23735 !        facd1=0.0d0
23736 !        facd2=0.0d0
23737         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23738         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23739                    - dGCLdR * pom &
23740                    - dPOLdR1 *  (erhead_tail(k,1))
23741 !     &             - dGLJdR * pom
23742
23743         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23744         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23745                    + dGCLdR * pom  &
23746                    + dPOLdR1 * (erhead_tail(k,1))
23747 !     &             + dGLJdR * pom
23748
23749
23750         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23751                   - dGCLdR * erhead(k) &
23752                   - dPOLdR1 * erhead_tail(k,1)
23753 !     &             - dGLJdR * erhead(k)
23754
23755         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23756                   + dGCLdR * erhead(k)  &
23757                   + dPOLdR1 * erhead_tail(k,1)
23758 !     &             + dGLJdR * erhead(k)
23759
23760        END DO
23761        endif
23762 !       print *,i,j,evdwij,epol,Fcav,ECL
23763        escbase=escbase+evdwij+epol+Fcav+ECL
23764        call sc_grad_scbase
23765          enddo
23766       enddo
23767
23768       return
23769       end subroutine eprot_sc_base
23770       SUBROUTINE sc_grad_scbase
23771       use calc_data
23772
23773        real (kind=8) :: dcosom1(3),dcosom2(3)
23774        eom1  =    &
23775               eps2der * eps2rt_om1   &
23776             - 2.0D0 * alf1 * eps3der &
23777             + sigder * sigsq_om1     &
23778             + dCAVdOM1               &
23779             + dGCLdOM1               &
23780             + dPOLdOM1
23781
23782        eom2  =  &
23783               eps2der * eps2rt_om2   &
23784             + 2.0D0 * alf2 * eps3der &
23785             + sigder * sigsq_om2     &
23786             + dCAVdOM2               &
23787             + dGCLdOM2               &
23788             + dPOLdOM2
23789
23790        eom12 =    &
23791               evdwij  * eps1_om12     &
23792             + eps2der * eps2rt_om12   &
23793             - 2.0D0 * alf12 * eps3der &
23794             + sigder *sigsq_om12      &
23795             + dCAVdOM12               &
23796             + dGCLdOM12
23797
23798 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23799 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23800 !               gg(1),gg(2),"rozne"
23801        DO k = 1, 3
23802         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23803         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23804         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23805         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23806                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23807                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23808         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23809                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23810                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23811         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23812         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23813        END DO
23814        RETURN
23815       END SUBROUTINE sc_grad_scbase
23816
23817
23818       subroutine epep_sc_base(epepbase)
23819       use calc_data
23820       logical :: lprn
23821 !el local variables
23822       integer :: iint,itypi,itypi1,itypj,subchap
23823       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23824       real(kind=8) :: evdw,sig0ij
23825       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23826                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23827                     sslipi,sslipj,faclip
23828       integer :: ii
23829       real(kind=8) :: fracinbuf
23830        real (kind=8) :: epepbase
23831        real (kind=8),dimension(4):: ener
23832        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23833        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23834         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23835         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23836         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23837         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23838         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23839         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23840        real(kind=8),dimension(3,2)::chead,erhead_tail
23841        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23842        integer troll
23843        eps_out=80.0d0
23844        epepbase=0.0d0
23845 !       do i=1,nres_molec(1)-1
23846         do i=ibond_start,ibond_end
23847         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23848 !C        itypi  = itype(i,1)
23849         dxi    = dc_norm(1,i)
23850         dyi    = dc_norm(2,i)
23851         dzi    = dc_norm(3,i)
23852 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23853         dsci_inv = vbld_inv(i+1)/2.0
23854         xi=(c(1,i)+c(1,i+1))/2.0
23855         yi=(c(2,i)+c(2,i+1))/2.0
23856         zi=(c(3,i)+c(3,i+1))/2.0
23857         xi=mod(xi,boxxsize)
23858          if (xi.lt.0) xi=xi+boxxsize
23859         yi=mod(yi,boxysize)
23860          if (yi.lt.0) yi=yi+boxysize
23861         zi=mod(zi,boxzsize)
23862          if (zi.lt.0) zi=zi+boxzsize
23863          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23864            itypj= itype(j,2)
23865            if (itype(j,2).eq.ntyp1_molec(2))cycle
23866            xj=c(1,j+nres)
23867            yj=c(2,j+nres)
23868            zj=c(3,j+nres)
23869            xj=dmod(xj,boxxsize)
23870            if (xj.lt.0) xj=xj+boxxsize
23871            yj=dmod(yj,boxysize)
23872            if (yj.lt.0) yj=yj+boxysize
23873            zj=dmod(zj,boxzsize)
23874            if (zj.lt.0) zj=zj+boxzsize
23875           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23876           xj_safe=xj
23877           yj_safe=yj
23878           zj_safe=zj
23879           subchap=0
23880
23881           do xshift=-1,1
23882           do yshift=-1,1
23883           do zshift=-1,1
23884           xj=xj_safe+xshift*boxxsize
23885           yj=yj_safe+yshift*boxysize
23886           zj=zj_safe+zshift*boxzsize
23887           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23888           if(dist_temp.lt.dist_init) then
23889             dist_init=dist_temp
23890             xj_temp=xj
23891             yj_temp=yj
23892             zj_temp=zj
23893             subchap=1
23894           endif
23895           enddo
23896           enddo
23897           enddo
23898           if (subchap.eq.1) then
23899           xj=xj_temp-xi
23900           yj=yj_temp-yi
23901           zj=zj_temp-zi
23902           else
23903           xj=xj_safe-xi
23904           yj=yj_safe-yi
23905           zj=zj_safe-zi
23906           endif
23907           dxj = dc_norm( 1, nres+j )
23908           dyj = dc_norm( 2, nres+j )
23909           dzj = dc_norm( 3, nres+j )
23910 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23911 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23912
23913 ! Gay-berne var's
23914           sig0ij = sigma_pepbase(itypj )
23915           chi1   = chi_pepbase(itypj,1 )
23916           chi2   = chi_pepbase(itypj,2 )
23917 !          chi1=0.0d0
23918 !          chi2=0.0d0
23919           chi12  = chi1 * chi2
23920           chip1  = chipp_pepbase(itypj,1 )
23921           chip2  = chipp_pepbase(itypj,2 )
23922 !          chip1=0.0d0
23923 !          chip2=0.0d0
23924           chip12 = chip1 * chip2
23925           chis1 = chis_pepbase(itypj,1)
23926           chis2 = chis_pepbase(itypj,2)
23927           chis12 = chis1 * chis2
23928           sig1 = sigmap1_pepbase(itypj)
23929           sig2 = sigmap2_pepbase(itypj)
23930 !       write (*,*) "sig1 = ", sig1
23931 !       write (*,*) "sig2 = ", sig2
23932        DO k = 1,3
23933 ! location of polar head is computed by taking hydrophobic centre
23934 ! and moving by a d1 * dc_norm vector
23935 ! see unres publications for very informative images
23936         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23937 ! + d1i * dc_norm(k, i+nres)
23938         chead(k,2) = c(k, j+nres)
23939 ! + d1j * dc_norm(k, j+nres)
23940 ! distance
23941 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23942 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23943         Rhead_distance(k) = chead(k,2) - chead(k,1)
23944 !        print *,gvdwc_pepbase(k,i)
23945
23946        END DO
23947        Rhead = dsqrt( &
23948           (Rhead_distance(1)*Rhead_distance(1)) &
23949         + (Rhead_distance(2)*Rhead_distance(2)) &
23950         + (Rhead_distance(3)*Rhead_distance(3)))
23951
23952 ! alpha factors from Fcav/Gcav
23953           b1 = alphasur_pepbase(1,itypj)
23954 !          b1=0.0d0
23955           b2 = alphasur_pepbase(2,itypj)
23956           b3 = alphasur_pepbase(3,itypj)
23957           b4 = alphasur_pepbase(4,itypj)
23958           alf1   = 0.0d0
23959           alf2   = 0.0d0
23960           alf12  = 0.0d0
23961           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23962 !          print *,i,j,rrij
23963           rij  = dsqrt(rrij)
23964 !----------------------------
23965        evdwij = 0.0d0
23966        ECL = 0.0d0
23967        Elj = 0.0d0
23968        Equad = 0.0d0
23969        Epol = 0.0d0
23970        Fcav=0.0d0
23971        eheadtail = 0.0d0
23972        dGCLdOM1 = 0.0d0
23973        dGCLdOM2 = 0.0d0
23974        dGCLdOM12 = 0.0d0
23975        dPOLdOM1 = 0.0d0
23976        dPOLdOM2 = 0.0d0
23977           Fcav = 0.0d0
23978           dFdR = 0.0d0
23979           dCAVdOM1  = 0.0d0
23980           dCAVdOM2  = 0.0d0
23981           dCAVdOM12 = 0.0d0
23982           dscj_inv = vbld_inv(j+nres)
23983           CALL sc_angular
23984 ! this should be in elgrad_init but om's are calculated by sc_angular
23985 ! which in turn is used by older potentials
23986 ! om = omega, sqom = om^2
23987           sqom1  = om1 * om1
23988           sqom2  = om2 * om2
23989           sqom12 = om12 * om12
23990
23991 ! now we calculate EGB - Gey-Berne
23992 ! It will be summed up in evdwij and saved in evdw
23993           sigsq     = 1.0D0  / sigsq
23994           sig       = sig0ij * dsqrt(sigsq)
23995           rij_shift = 1.0/rij - sig + sig0ij
23996           IF (rij_shift.le.0.0D0) THEN
23997            evdw = 1.0D20
23998            RETURN
23999           END IF
24000           sigder = -sig * sigsq
24001           rij_shift = 1.0D0 / rij_shift
24002           fac       = rij_shift**expon
24003           c1        = fac  * fac * aa_pepbase(itypj)
24004 !          c1        = 0.0d0
24005           c2        = fac  * bb_pepbase(itypj)
24006 !          c2        = 0.0d0
24007           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24008           eps2der   = eps3rt * evdwij
24009           eps3der   = eps2rt * evdwij
24010 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24011           evdwij    = eps2rt * eps3rt * evdwij
24012           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24013           fac    = -expon * (c1 + evdwij) * rij_shift
24014           sigder = fac * sigder
24015 !          fac    = rij * fac
24016 ! Calculate distance derivative
24017           gg(1) =  fac
24018           gg(2) =  fac
24019           gg(3) =  fac
24020           fac = chis1 * sqom1 + chis2 * sqom2 &
24021           - 2.0d0 * chis12 * om1 * om2 * om12
24022 ! we will use pom later in Gcav, so dont mess with it!
24023           pom = 1.0d0 - chis1 * chis2 * sqom12
24024           Lambf = (1.0d0 - (fac / pom))
24025           Lambf = dsqrt(Lambf)
24026           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24027 !       write (*,*) "sparrow = ", sparrow
24028           Chif = 1.0d0/rij * sparrow
24029           ChiLambf = Chif * Lambf
24030           eagle = dsqrt(ChiLambf)
24031           bat = ChiLambf ** 11.0d0
24032           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24033           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24034           botsq = bot * bot
24035           Fcav = top / bot
24036 !          print *,i,j,Fcav
24037           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24038           dbot = 12.0d0 * b4 * bat * Lambf
24039           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24040 !       dFdR = 0.0d0
24041 !      write (*,*) "dFcav/dR = ", dFdR
24042           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24043           dbot = 12.0d0 * b4 * bat * Chif
24044           eagle = Lambf * pom
24045           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24046           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24047           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24048               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24049
24050           dFdL = ((dtop * bot - top * dbot) / botsq)
24051 !       dFdL = 0.0d0
24052           dCAVdOM1  = dFdL * ( dFdOM1 )
24053           dCAVdOM2  = dFdL * ( dFdOM2 )
24054           dCAVdOM12 = dFdL * ( dFdOM12 )
24055
24056           ertail(1) = xj*rij
24057           ertail(2) = yj*rij
24058           ertail(3) = zj*rij
24059        DO k = 1, 3
24060 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24061 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24062         pom = ertail(k)
24063 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24064         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24065                   - (( dFdR + gg(k) ) * pom)/2.0
24066 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24067 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24068 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24069 !     &             - ( dFdR * pom )
24070         pom = ertail(k)
24071 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24072         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24073                   + (( dFdR + gg(k) ) * pom)
24074 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24075 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24076 !c!     &             + ( dFdR * pom )
24077
24078         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24079                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24080 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24081
24082 !c!     &             - ( dFdR * ertail(k))
24083
24084         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24085                   + (( dFdR + gg(k) ) * ertail(k))
24086 !c!     &             + ( dFdR * ertail(k))
24087
24088         gg(k) = 0.0d0
24089 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24090 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24091       END DO
24092
24093
24094        w1 = wdipdip_pepbase(1,itypj)
24095        w2 = -wdipdip_pepbase(3,itypj)/2.0
24096        w3 = wdipdip_pepbase(2,itypj)
24097 !       w1=0.0d0
24098 !       w2=0.0d0
24099 !c!-------------------------------------------------------------------
24100 !c! ECL
24101 !       w3=0.0d0
24102        fac = (om12 - 3.0d0 * om1 * om2)
24103        c1 = (w1 / (Rhead**3.0d0)) * fac
24104        c2 = (w2 / Rhead ** 6.0d0)  &
24105          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24106        c3= (w3/ Rhead ** 6.0d0)  &
24107          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24108
24109        ECL = c1 - c2 + c3
24110
24111        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24112        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24113          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24114        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24115          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24116
24117        dGCLdR = c1 - c2 + c3
24118 !c! dECL/dom1
24119        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24120        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24121          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24122        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24123        dGCLdOM1 = c1 - c2 + c3
24124 !c! dECL/dom2
24125        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24126        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24127          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24128        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24129
24130        dGCLdOM2 = c1 - c2 + c3
24131 !c! dECL/dom12
24132        c1 = w1 / (Rhead ** 3.0d0)
24133        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24134        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24135        dGCLdOM12 = c1 - c2 + c3
24136        DO k= 1, 3
24137         erhead(k) = Rhead_distance(k)/Rhead
24138        END DO
24139        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24140        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24141 !       facd1 = d1 * vbld_inv(i+nres)
24142 !       facd2 = d2 * vbld_inv(j+nres)
24143        DO k = 1, 3
24144
24145 !        pom = erhead(k)
24146 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24147 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24148 !                  - dGCLdR * pom
24149         pom = erhead(k)
24150 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24151         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24152                   + dGCLdR * pom
24153
24154         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24155                   - dGCLdR * erhead(k)/2.0d0
24156 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24157         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24158                   - dGCLdR * erhead(k)/2.0d0
24159 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24160         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24161                   + dGCLdR * erhead(k)
24162        END DO
24163 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24164        epepbase=epepbase+evdwij+Fcav+ECL
24165        call sc_grad_pepbase
24166        enddo
24167        enddo
24168       END SUBROUTINE epep_sc_base
24169       SUBROUTINE sc_grad_pepbase
24170       use calc_data
24171
24172        real (kind=8) :: dcosom1(3),dcosom2(3)
24173        eom1  =    &
24174               eps2der * eps2rt_om1   &
24175             - 2.0D0 * alf1 * eps3der &
24176             + sigder * sigsq_om1     &
24177             + dCAVdOM1               &
24178             + dGCLdOM1               &
24179             + dPOLdOM1
24180
24181        eom2  =  &
24182               eps2der * eps2rt_om2   &
24183             + 2.0D0 * alf2 * eps3der &
24184             + sigder * sigsq_om2     &
24185             + dCAVdOM2               &
24186             + dGCLdOM2               &
24187             + dPOLdOM2
24188
24189        eom12 =    &
24190               evdwij  * eps1_om12     &
24191             + eps2der * eps2rt_om12   &
24192             - 2.0D0 * alf12 * eps3der &
24193             + sigder *sigsq_om12      &
24194             + dCAVdOM12               &
24195             + dGCLdOM12
24196 !        om12=0.0
24197 !        eom12=0.0
24198 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24199 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24200 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24201 !                 *dsci_inv*2.0
24202 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24203 !               gg(1),gg(2),"rozne"
24204        DO k = 1, 3
24205         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24206         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24207         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24208         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24209                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24210                  *dsci_inv*2.0 &
24211                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24212         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24213                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24214                  *dsci_inv*2.0 &
24215                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24216 !         print *,eom12,eom2,om12,om2
24217 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24218 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24219         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24220                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24221                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24222         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24223        END DO
24224        RETURN
24225       END SUBROUTINE sc_grad_pepbase
24226       subroutine eprot_sc_phosphate(escpho)
24227       use calc_data
24228 !      implicit real*8 (a-h,o-z)
24229 !      include 'DIMENSIONS'
24230 !      include 'COMMON.GEO'
24231 !      include 'COMMON.VAR'
24232 !      include 'COMMON.LOCAL'
24233 !      include 'COMMON.CHAIN'
24234 !      include 'COMMON.DERIV'
24235 !      include 'COMMON.NAMES'
24236 !      include 'COMMON.INTERACT'
24237 !      include 'COMMON.IOUNITS'
24238 !      include 'COMMON.CALC'
24239 !      include 'COMMON.CONTROL'
24240 !      include 'COMMON.SBRIDGE'
24241       logical :: lprn
24242 !el local variables
24243       integer :: iint,itypi,itypi1,itypj,subchap
24244       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24245       real(kind=8) :: evdw,sig0ij
24246       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24247                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24248                     sslipi,sslipj,faclip,alpha_sco
24249       integer :: ii
24250       real(kind=8) :: fracinbuf
24251        real (kind=8) :: escpho
24252        real (kind=8),dimension(4):: ener
24253        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24254        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24255         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24256         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24257         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24258         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24259         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24260         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24261        real(kind=8),dimension(3,2)::chead,erhead_tail
24262        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24263        integer troll
24264        eps_out=80.0d0
24265        escpho=0.0d0
24266 !       do i=1,nres_molec(1)
24267         do i=ibond_start,ibond_end
24268         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24269         itypi  = itype(i,1)
24270         dxi    = dc_norm(1,nres+i)
24271         dyi    = dc_norm(2,nres+i)
24272         dzi    = dc_norm(3,nres+i)
24273         dsci_inv = vbld_inv(i+nres)
24274         xi=c(1,nres+i)
24275         yi=c(2,nres+i)
24276         zi=c(3,nres+i)
24277         xi=mod(xi,boxxsize)
24278          if (xi.lt.0) xi=xi+boxxsize
24279         yi=mod(yi,boxysize)
24280          if (yi.lt.0) yi=yi+boxysize
24281         zi=mod(zi,boxzsize)
24282          if (zi.lt.0) zi=zi+boxzsize
24283          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24284            itypj= itype(j,2)
24285            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24286             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24287            xj=(c(1,j)+c(1,j+1))/2.0
24288            yj=(c(2,j)+c(2,j+1))/2.0
24289            zj=(c(3,j)+c(3,j+1))/2.0
24290            xj=dmod(xj,boxxsize)
24291            if (xj.lt.0) xj=xj+boxxsize
24292            yj=dmod(yj,boxysize)
24293            if (yj.lt.0) yj=yj+boxysize
24294            zj=dmod(zj,boxzsize)
24295            if (zj.lt.0) zj=zj+boxzsize
24296           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24297           xj_safe=xj
24298           yj_safe=yj
24299           zj_safe=zj
24300           subchap=0
24301           do xshift=-1,1
24302           do yshift=-1,1
24303           do zshift=-1,1
24304           xj=xj_safe+xshift*boxxsize
24305           yj=yj_safe+yshift*boxysize
24306           zj=zj_safe+zshift*boxzsize
24307           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24308           if(dist_temp.lt.dist_init) then
24309             dist_init=dist_temp
24310             xj_temp=xj
24311             yj_temp=yj
24312             zj_temp=zj
24313             subchap=1
24314           endif
24315           enddo
24316           enddo
24317           enddo
24318           if (subchap.eq.1) then
24319           xj=xj_temp-xi
24320           yj=yj_temp-yi
24321           zj=zj_temp-zi
24322           else
24323           xj=xj_safe-xi
24324           yj=yj_safe-yi
24325           zj=zj_safe-zi
24326           endif
24327           dxj = dc_norm( 1,j )
24328           dyj = dc_norm( 2,j )
24329           dzj = dc_norm( 3,j )
24330           dscj_inv = vbld_inv(j+1)
24331
24332 ! Gay-berne var's
24333           sig0ij = sigma_scpho(itypi )
24334           chi1   = chi_scpho(itypi,1 )
24335           chi2   = chi_scpho(itypi,2 )
24336 !          chi1=0.0d0
24337 !          chi2=0.0d0
24338           chi12  = chi1 * chi2
24339           chip1  = chipp_scpho(itypi,1 )
24340           chip2  = chipp_scpho(itypi,2 )
24341 !          chip1=0.0d0
24342 !          chip2=0.0d0
24343           chip12 = chip1 * chip2
24344           chis1 = chis_scpho(itypi,1)
24345           chis2 = chis_scpho(itypi,2)
24346           chis12 = chis1 * chis2
24347           sig1 = sigmap1_scpho(itypi)
24348           sig2 = sigmap2_scpho(itypi)
24349 !       write (*,*) "sig1 = ", sig1
24350 !       write (*,*) "sig1 = ", sig1
24351 !       write (*,*) "sig2 = ", sig2
24352 ! alpha factors from Fcav/Gcav
24353           alf1   = 0.0d0
24354           alf2   = 0.0d0
24355           alf12  = 0.0d0
24356           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24357
24358           b1 = alphasur_scpho(1,itypi)
24359 !          b1=0.0d0
24360           b2 = alphasur_scpho(2,itypi)
24361           b3 = alphasur_scpho(3,itypi)
24362           b4 = alphasur_scpho(4,itypi)
24363 ! used to determine whether we want to do quadrupole calculations
24364 ! used by Fgb
24365        eps_in = epsintab_scpho(itypi)
24366        if (eps_in.eq.0.0) eps_in=1.0
24367        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24368 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24369 !-------------------------------------------------------------------
24370 ! tail location and distance calculations
24371           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24372           d1j = 0.0
24373        DO k = 1,3
24374 ! location of polar head is computed by taking hydrophobic centre
24375 ! and moving by a d1 * dc_norm vector
24376 ! see unres publications for very informative images
24377         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24378         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24379 ! distance
24380 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24381 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24382         Rhead_distance(k) = chead(k,2) - chead(k,1)
24383        END DO
24384 ! pitagoras (root of sum of squares)
24385        Rhead = dsqrt( &
24386           (Rhead_distance(1)*Rhead_distance(1)) &
24387         + (Rhead_distance(2)*Rhead_distance(2)) &
24388         + (Rhead_distance(3)*Rhead_distance(3)))
24389        Rhead_sq=Rhead**2.0
24390 !-------------------------------------------------------------------
24391 ! zero everything that should be zero'ed
24392        evdwij = 0.0d0
24393        ECL = 0.0d0
24394        Elj = 0.0d0
24395        Equad = 0.0d0
24396        Epol = 0.0d0
24397        Fcav=0.0d0
24398        eheadtail = 0.0d0
24399        dGCLdR=0.0d0
24400        dGCLdOM1 = 0.0d0
24401        dGCLdOM2 = 0.0d0
24402        dGCLdOM12 = 0.0d0
24403        dPOLdOM1 = 0.0d0
24404        dPOLdOM2 = 0.0d0
24405           Fcav = 0.0d0
24406           dFdR = 0.0d0
24407           dCAVdOM1  = 0.0d0
24408           dCAVdOM2  = 0.0d0
24409           dCAVdOM12 = 0.0d0
24410           dscj_inv = vbld_inv(j+1)/2.0
24411 !dhead_scbasej(itypi,itypj)
24412 !          print *,i,j,dscj_inv,dsci_inv
24413 ! rij holds 1/(distance of Calpha atoms)
24414           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24415           rij  = dsqrt(rrij)
24416 !----------------------------
24417           CALL sc_angular
24418 ! this should be in elgrad_init but om's are calculated by sc_angular
24419 ! which in turn is used by older potentials
24420 ! om = omega, sqom = om^2
24421           sqom1  = om1 * om1
24422           sqom2  = om2 * om2
24423           sqom12 = om12 * om12
24424
24425 ! now we calculate EGB - Gey-Berne
24426 ! It will be summed up in evdwij and saved in evdw
24427           sigsq     = 1.0D0  / sigsq
24428           sig       = sig0ij * dsqrt(sigsq)
24429 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24430           rij_shift = 1.0/rij - sig + sig0ij
24431           IF (rij_shift.le.0.0D0) THEN
24432            evdw = 1.0D20
24433            RETURN
24434           END IF
24435           sigder = -sig * sigsq
24436           rij_shift = 1.0D0 / rij_shift
24437           fac       = rij_shift**expon
24438           c1        = fac  * fac * aa_scpho(itypi)
24439 !          c1        = 0.0d0
24440           c2        = fac  * bb_scpho(itypi)
24441 !          c2        = 0.0d0
24442           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24443           eps2der   = eps3rt * evdwij
24444           eps3der   = eps2rt * evdwij
24445 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24446           evdwij    = eps2rt * eps3rt * evdwij
24447           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24448           fac    = -expon * (c1 + evdwij) * rij_shift
24449           sigder = fac * sigder
24450 !          fac    = rij * fac
24451 ! Calculate distance derivative
24452           gg(1) =  fac
24453           gg(2) =  fac
24454           gg(3) =  fac
24455           fac = chis1 * sqom1 + chis2 * sqom2 &
24456           - 2.0d0 * chis12 * om1 * om2 * om12
24457 ! we will use pom later in Gcav, so dont mess with it!
24458           pom = 1.0d0 - chis1 * chis2 * sqom12
24459           Lambf = (1.0d0 - (fac / pom))
24460           Lambf = dsqrt(Lambf)
24461           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24462 !       write (*,*) "sparrow = ", sparrow
24463           Chif = 1.0d0/rij * sparrow
24464           ChiLambf = Chif * Lambf
24465           eagle = dsqrt(ChiLambf)
24466           bat = ChiLambf ** 11.0d0
24467           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24468           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24469           botsq = bot * bot
24470           Fcav = top / bot
24471           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24472           dbot = 12.0d0 * b4 * bat * Lambf
24473           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24474 !       dFdR = 0.0d0
24475 !      write (*,*) "dFcav/dR = ", dFdR
24476           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24477           dbot = 12.0d0 * b4 * bat * Chif
24478           eagle = Lambf * pom
24479           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24480           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24481           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24482               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24483
24484           dFdL = ((dtop * bot - top * dbot) / botsq)
24485 !       dFdL = 0.0d0
24486           dCAVdOM1  = dFdL * ( dFdOM1 )
24487           dCAVdOM2  = dFdL * ( dFdOM2 )
24488           dCAVdOM12 = dFdL * ( dFdOM12 )
24489
24490           ertail(1) = xj*rij
24491           ertail(2) = yj*rij
24492           ertail(3) = zj*rij
24493        DO k = 1, 3
24494 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24495 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24496 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24497
24498         pom = ertail(k)
24499 !        print *,pom,gg(k),dFdR
24500 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24501         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24502                   - (( dFdR + gg(k) ) * pom)
24503 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24504 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24505 !     &             - ( dFdR * pom )
24506 !        pom = ertail(k)
24507 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24508 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24509 !                  + (( dFdR + gg(k) ) * pom)
24510 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24511 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24512 !c!     &             + ( dFdR * pom )
24513
24514         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24515                   - (( dFdR + gg(k) ) * ertail(k))
24516 !c!     &             - ( dFdR * ertail(k))
24517
24518         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24519                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24520
24521         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24522                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24523
24524 !c!     &             + ( dFdR * ertail(k))
24525
24526         gg(k) = 0.0d0
24527         ENDDO
24528 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24529 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24530 !      alphapol1 = alphapol_scpho(itypi)
24531        if (wqq_scpho(itypi).ne.0.0) then
24532        Qij=wqq_scpho(itypi)/eps_in
24533        alpha_sco=1.d0/alphi_scpho(itypi)
24534 !       Qij=0.0
24535        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24536 !c! derivative of Ecl is Gcl...
24537        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24538                 (Rhead*alpha_sco+1) ) / Rhead_sq
24539        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24540        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24541        w1        = wqdip_scpho(1,itypi)
24542        w2        = wqdip_scpho(2,itypi)
24543 !       w1=0.0d0
24544 !       w2=0.0d0
24545 !       pis       = sig0head_scbase(itypi,itypj)
24546 !       eps_head   = epshead_scbase(itypi,itypj)
24547 !c!-------------------------------------------------------------------
24548
24549 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24550 !c!     &        +dhead(1,1,itypi,itypj))**2))
24551 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24552 !c!     &        +dhead(2,1,itypi,itypj))**2))
24553
24554 !c!-------------------------------------------------------------------
24555 !c! ecl
24556        sparrow  = w1  *  om1
24557        hawk     = w2 *  (1.0d0 - sqom2)
24558        Ecl = sparrow / Rhead**2.0d0 &
24559            - hawk    / Rhead**4.0d0
24560 !c!-------------------------------------------------------------------
24561        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24562            1.0/rij,sparrow
24563
24564 !c! derivative of ecl is Gcl
24565 !c! dF/dr part
24566        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24567                 + 4.0d0 * hawk    / Rhead**5.0d0
24568 !c! dF/dom1
24569        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24570 !c! dF/dom2
24571        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24572        endif
24573
24574 !c--------------------------------------------------------------------
24575 !c Polarization energy
24576 !c Epol
24577        R1 = 0.0d0
24578        DO k = 1, 3
24579 !c! Calculate head-to-tail distances tail is center of side-chain
24580         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24581        END DO
24582 !c! Pitagoras
24583        R1 = dsqrt(R1)
24584
24585       alphapol1 = alphapol_scpho(itypi)
24586 !      alphapol1=0.0
24587        MomoFac1 = (1.0d0 - chi2 * sqom1)
24588        RR1  = R1 * R1 / MomoFac1
24589        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24590 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24591        fgb1 = sqrt( RR1 + a12sq * ee1)
24592 !       eps_inout_fac=0.0d0
24593        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24594 ! derivative of Epol is Gpol...
24595        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24596                 / (fgb1 ** 5.0d0)
24597        dFGBdR1 = ( (R1 / MomoFac1) &
24598              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24599              / ( 2.0d0 * fgb1 )
24600        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24601                * (2.0d0 - 0.5d0 * ee1) ) &
24602                / (2.0d0 * fgb1)
24603        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24604 !       dPOLdR1 = 0.0d0
24605 !       dPOLdOM1 = 0.0d0
24606        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24607                * (2.0d0 - 0.5d0 * ee1) ) &
24608                / (2.0d0 * fgb1)
24609
24610        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24611        dPOLdOM2 = 0.0
24612        DO k = 1, 3
24613         erhead(k) = Rhead_distance(k)/Rhead
24614         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24615        END DO
24616
24617        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24618        erdxj = scalar( erhead(1), dC_norm(1,j) )
24619        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24620 !       bat=0.0d0
24621        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24622        facd1 = d1i * vbld_inv(i+nres)
24623        facd2 = d1j * vbld_inv(j)
24624 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24625
24626        DO k = 1, 3
24627         hawk = (erhead_tail(k,1) + &
24628         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24629 !        facd1=0.0d0
24630 !        facd2=0.0d0
24631 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24632 !                pom,(erhead_tail(k,1))
24633
24634 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24635         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24636         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24637                    - dGCLdR * pom &
24638                    - dPOLdR1 *  (erhead_tail(k,1))
24639 !     &             - dGLJdR * pom
24640
24641         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24642 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24643 !                   + dGCLdR * pom  &
24644 !                   + dPOLdR1 * (erhead_tail(k,1))
24645 !     &             + dGLJdR * pom
24646
24647
24648         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24649                   - dGCLdR * erhead(k) &
24650                   - dPOLdR1 * erhead_tail(k,1)
24651 !     &             - dGLJdR * erhead(k)
24652
24653         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24654                   + (dGCLdR * erhead(k)  &
24655                   + dPOLdR1 * erhead_tail(k,1))/2.0
24656         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24657                   + (dGCLdR * erhead(k)  &
24658                   + dPOLdR1 * erhead_tail(k,1))/2.0
24659
24660 !     &             + dGLJdR * erhead(k)
24661 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24662
24663        END DO
24664 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24665        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24666         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24667        escpho=escpho+evdwij+epol+Fcav+ECL
24668        call sc_grad_scpho
24669          enddo
24670
24671       enddo
24672
24673       return
24674       end subroutine eprot_sc_phosphate
24675       SUBROUTINE sc_grad_scpho
24676       use calc_data
24677
24678        real (kind=8) :: dcosom1(3),dcosom2(3)
24679        eom1  =    &
24680               eps2der * eps2rt_om1   &
24681             - 2.0D0 * alf1 * eps3der &
24682             + sigder * sigsq_om1     &
24683             + dCAVdOM1               &
24684             + dGCLdOM1               &
24685             + dPOLdOM1
24686
24687        eom2  =  &
24688               eps2der * eps2rt_om2   &
24689             + 2.0D0 * alf2 * eps3der &
24690             + sigder * sigsq_om2     &
24691             + dCAVdOM2               &
24692             + dGCLdOM2               &
24693             + dPOLdOM2
24694
24695        eom12 =    &
24696               evdwij  * eps1_om12     &
24697             + eps2der * eps2rt_om12   &
24698             - 2.0D0 * alf12 * eps3der &
24699             + sigder *sigsq_om12      &
24700             + dCAVdOM12               &
24701             + dGCLdOM12
24702 !        om12=0.0
24703 !        eom12=0.0
24704 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24705 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24706 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24707 !                 *dsci_inv*2.0
24708 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24709 !               gg(1),gg(2),"rozne"
24710        DO k = 1, 3
24711         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24712         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24713         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24714         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24715                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24716                  *dscj_inv*2.0 &
24717                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24718         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24719                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24720                  *dscj_inv*2.0 &
24721                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24722         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24723                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24724                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24725
24726 !         print *,eom12,eom2,om12,om2
24727 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24728 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24729 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24730 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24731 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24732         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24733        END DO
24734        RETURN
24735       END SUBROUTINE sc_grad_scpho
24736       subroutine eprot_pep_phosphate(epeppho)
24737       use calc_data
24738 !      implicit real*8 (a-h,o-z)
24739 !      include 'DIMENSIONS'
24740 !      include 'COMMON.GEO'
24741 !      include 'COMMON.VAR'
24742 !      include 'COMMON.LOCAL'
24743 !      include 'COMMON.CHAIN'
24744 !      include 'COMMON.DERIV'
24745 !      include 'COMMON.NAMES'
24746 !      include 'COMMON.INTERACT'
24747 !      include 'COMMON.IOUNITS'
24748 !      include 'COMMON.CALC'
24749 !      include 'COMMON.CONTROL'
24750 !      include 'COMMON.SBRIDGE'
24751       logical :: lprn
24752 !el local variables
24753       integer :: iint,itypi,itypi1,itypj,subchap
24754       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24755       real(kind=8) :: evdw,sig0ij
24756       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24757                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24758                     sslipi,sslipj,faclip
24759       integer :: ii
24760       real(kind=8) :: fracinbuf
24761        real (kind=8) :: epeppho
24762        real (kind=8),dimension(4):: ener
24763        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24764        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24765         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24766         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24767         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24768         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24769         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24770         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24771        real(kind=8),dimension(3,2)::chead,erhead_tail
24772        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24773        integer troll
24774        real (kind=8) :: dcosom1(3),dcosom2(3)
24775        epeppho=0.0d0
24776 !       do i=1,nres_molec(1)
24777         do i=ibond_start,ibond_end
24778         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24779         itypi  = itype(i,1)
24780         dsci_inv = vbld_inv(i+1)/2.0
24781         dxi    = dc_norm(1,i)
24782         dyi    = dc_norm(2,i)
24783         dzi    = dc_norm(3,i)
24784         xi=(c(1,i)+c(1,i+1))/2.0
24785         yi=(c(2,i)+c(2,i+1))/2.0
24786         zi=(c(3,i)+c(3,i+1))/2.0
24787         xi=mod(xi,boxxsize)
24788          if (xi.lt.0) xi=xi+boxxsize
24789         yi=mod(yi,boxysize)
24790          if (yi.lt.0) yi=yi+boxysize
24791         zi=mod(zi,boxzsize)
24792          if (zi.lt.0) zi=zi+boxzsize
24793          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24794            itypj= itype(j,2)
24795            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24796             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24797            xj=(c(1,j)+c(1,j+1))/2.0
24798            yj=(c(2,j)+c(2,j+1))/2.0
24799            zj=(c(3,j)+c(3,j+1))/2.0
24800            xj=dmod(xj,boxxsize)
24801            if (xj.lt.0) xj=xj+boxxsize
24802            yj=dmod(yj,boxysize)
24803            if (yj.lt.0) yj=yj+boxysize
24804            zj=dmod(zj,boxzsize)
24805            if (zj.lt.0) zj=zj+boxzsize
24806           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24807           xj_safe=xj
24808           yj_safe=yj
24809           zj_safe=zj
24810           subchap=0
24811           do xshift=-1,1
24812           do yshift=-1,1
24813           do zshift=-1,1
24814           xj=xj_safe+xshift*boxxsize
24815           yj=yj_safe+yshift*boxysize
24816           zj=zj_safe+zshift*boxzsize
24817           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24818           if(dist_temp.lt.dist_init) then
24819             dist_init=dist_temp
24820             xj_temp=xj
24821             yj_temp=yj
24822             zj_temp=zj
24823             subchap=1
24824           endif
24825           enddo
24826           enddo
24827           enddo
24828           if (subchap.eq.1) then
24829           xj=xj_temp-xi
24830           yj=yj_temp-yi
24831           zj=zj_temp-zi
24832           else
24833           xj=xj_safe-xi
24834           yj=yj_safe-yi
24835           zj=zj_safe-zi
24836           endif
24837           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24838           rij  = dsqrt(rrij)
24839           dxj = dc_norm( 1,j )
24840           dyj = dc_norm( 2,j )
24841           dzj = dc_norm( 3,j )
24842           dscj_inv = vbld_inv(j+1)/2.0
24843 ! Gay-berne var's
24844           sig0ij = sigma_peppho
24845 !          chi1=0.0d0
24846 !          chi2=0.0d0
24847           chi12  = chi1 * chi2
24848 !          chip1=0.0d0
24849 !          chip2=0.0d0
24850           chip12 = chip1 * chip2
24851 !          chis1 = 0.0d0
24852 !          chis2 = 0.0d0
24853           chis12 = chis1 * chis2
24854           sig1 = sigmap1_peppho
24855           sig2 = sigmap2_peppho
24856 !       write (*,*) "sig1 = ", sig1
24857 !       write (*,*) "sig1 = ", sig1
24858 !       write (*,*) "sig2 = ", sig2
24859 ! alpha factors from Fcav/Gcav
24860           alf1   = 0.0d0
24861           alf2   = 0.0d0
24862           alf12  = 0.0d0
24863           b1 = alphasur_peppho(1)
24864 !          b1=0.0d0
24865           b2 = alphasur_peppho(2)
24866           b3 = alphasur_peppho(3)
24867           b4 = alphasur_peppho(4)
24868           CALL sc_angular
24869        sqom1=om1*om1
24870        evdwij = 0.0d0
24871        ECL = 0.0d0
24872        Elj = 0.0d0
24873        Equad = 0.0d0
24874        Epol = 0.0d0
24875        Fcav=0.0d0
24876        eheadtail = 0.0d0
24877        dGCLdR=0.0d0
24878        dGCLdOM1 = 0.0d0
24879        dGCLdOM2 = 0.0d0
24880        dGCLdOM12 = 0.0d0
24881        dPOLdOM1 = 0.0d0
24882        dPOLdOM2 = 0.0d0
24883           Fcav = 0.0d0
24884           dFdR = 0.0d0
24885           dCAVdOM1  = 0.0d0
24886           dCAVdOM2  = 0.0d0
24887           dCAVdOM12 = 0.0d0
24888           rij_shift = rij
24889           fac       = rij_shift**expon
24890           c1        = fac  * fac * aa_peppho
24891 !          c1        = 0.0d0
24892           c2        = fac  * bb_peppho
24893 !          c2        = 0.0d0
24894           evdwij    =  c1 + c2
24895 ! Now cavity....................
24896        eagle = dsqrt(1.0/rij_shift)
24897        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24898           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24899           botsq = bot * bot
24900           Fcav = top / bot
24901           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24902           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24903           dFdR = ((dtop * bot - top * dbot) / botsq)
24904        w1        = wqdip_peppho(1)
24905        w2        = wqdip_peppho(2)
24906 !       w1=0.0d0
24907 !       w2=0.0d0
24908 !       pis       = sig0head_scbase(itypi,itypj)
24909 !       eps_head   = epshead_scbase(itypi,itypj)
24910 !c!-------------------------------------------------------------------
24911
24912 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24913 !c!     &        +dhead(1,1,itypi,itypj))**2))
24914 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24915 !c!     &        +dhead(2,1,itypi,itypj))**2))
24916
24917 !c!-------------------------------------------------------------------
24918 !c! ecl
24919        sparrow  = w1  *  om1
24920        hawk     = w2 *  (1.0d0 - sqom1)
24921        Ecl = sparrow * rij_shift**2.0d0 &
24922            - hawk    * rij_shift**4.0d0
24923 !c!-------------------------------------------------------------------
24924 !c! derivative of ecl is Gcl
24925 !c! dF/dr part
24926 !       rij_shift=5.0
24927        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24928                 + 4.0d0 * hawk    * rij_shift**5.0d0
24929 !c! dF/dom1
24930        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24931 !c! dF/dom2
24932        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24933        eom1  =    dGCLdOM1+dGCLdOM2
24934        eom2  =    0.0
24935
24936           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24937 !          fac=0.0
24938           gg(1) =  fac*xj*rij
24939           gg(2) =  fac*yj*rij
24940           gg(3) =  fac*zj*rij
24941          do k=1,3
24942          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24943          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24944          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24945          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24946          gg(k)=0.0
24947          enddo
24948
24949       DO k = 1, 3
24950         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24951         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24952         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24953         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24954 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24955         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24956 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24957         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24958                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24959         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24960                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24961         enddo
24962        epeppho=epeppho+evdwij+Fcav+ECL
24963 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24964        enddo
24965        enddo
24966       end subroutine eprot_pep_phosphate
24967 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24968       subroutine emomo(evdw)
24969       use calc_data
24970       use comm_momo
24971 !      implicit real*8 (a-h,o-z)
24972 !      include 'DIMENSIONS'
24973 !      include 'COMMON.GEO'
24974 !      include 'COMMON.VAR'
24975 !      include 'COMMON.LOCAL'
24976 !      include 'COMMON.CHAIN'
24977 !      include 'COMMON.DERIV'
24978 !      include 'COMMON.NAMES'
24979 !      include 'COMMON.INTERACT'
24980 !      include 'COMMON.IOUNITS'
24981 !      include 'COMMON.CALC'
24982 !      include 'COMMON.CONTROL'
24983 !      include 'COMMON.SBRIDGE'
24984       logical :: lprn
24985 !el local variables
24986       integer :: iint,itypi1,subchap,isel
24987       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24988       real(kind=8) :: evdw
24989       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24990                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24991                     sslipi,sslipj,faclip,alpha_sco
24992       integer :: ii
24993       real(kind=8) :: fracinbuf
24994        real (kind=8) :: escpho
24995        real (kind=8),dimension(4):: ener
24996        real(kind=8) :: b1,b2,egb
24997        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24998         Lambf,&
24999         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25000         dFdOM2,dFdL,dFdOM12,&
25001         federmaus,&
25002         d1i,d1j
25003 !       real(kind=8),dimension(3,2)::erhead_tail
25004 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25005        real(kind=8) ::  facd4, adler, Fgb, facd3
25006        integer troll,jj,istate
25007        real (kind=8) :: dcosom1(3),dcosom2(3)
25008        eps_out=80.0d0
25009        sss_ele_cut=1.0d0
25010 !       print *,"EVDW KURW",evdw,nres
25011       do i=iatsc_s,iatsc_e
25012 !        print *,"I am in EVDW",i
25013         itypi=iabs(itype(i,1))
25014 !        if (i.ne.47) cycle
25015         if (itypi.eq.ntyp1) cycle
25016         itypi1=iabs(itype(i+1,1))
25017         xi=c(1,nres+i)
25018         yi=c(2,nres+i)
25019         zi=c(3,nres+i)
25020           xi=dmod(xi,boxxsize)
25021           if (xi.lt.0) xi=xi+boxxsize
25022           yi=dmod(yi,boxysize)
25023           if (yi.lt.0) yi=yi+boxysize
25024           zi=dmod(zi,boxzsize)
25025           if (zi.lt.0) zi=zi+boxzsize
25026
25027        if ((zi.gt.bordlipbot)  &
25028         .and.(zi.lt.bordliptop)) then
25029 !C the energy transfer exist
25030         if (zi.lt.buflipbot) then
25031 !C what fraction I am in
25032          fracinbuf=1.0d0-  &
25033               ((zi-bordlipbot)/lipbufthick)
25034 !C lipbufthick is thickenes of lipid buffore
25035          sslipi=sscalelip(fracinbuf)
25036          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25037         elseif (zi.gt.bufliptop) then
25038          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25039          sslipi=sscalelip(fracinbuf)
25040          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25041         else
25042          sslipi=1.0d0
25043          ssgradlipi=0.0
25044         endif
25045        else
25046          sslipi=0.0d0
25047          ssgradlipi=0.0
25048        endif
25049 !       print *, sslipi,ssgradlipi
25050         dxi=dc_norm(1,nres+i)
25051         dyi=dc_norm(2,nres+i)
25052         dzi=dc_norm(3,nres+i)
25053 !        dsci_inv=dsc_inv(itypi)
25054         dsci_inv=vbld_inv(i+nres)
25055 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25056 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25057 !
25058 ! Calculate SC interaction energy.
25059 !
25060         do iint=1,nint_gr(i)
25061           do j=istart(i,iint),iend(i,iint)
25062 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25063             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25064               call dyn_ssbond_ene(i,j,evdwij)
25065               evdw=evdw+evdwij
25066               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25067                               'evdw',i,j,evdwij,' ss'
25068 !              if (energy_dec) write (iout,*) &
25069 !                              'evdw',i,j,evdwij,' ss'
25070              do k=j+1,iend(i,iint)
25071 !C search over all next residues
25072               if (dyn_ss_mask(k)) then
25073 !C check if they are cysteins
25074 !C              write(iout,*) 'k=',k
25075
25076 !c              write(iout,*) "PRZED TRI", evdwij
25077 !               evdwij_przed_tri=evdwij
25078               call triple_ssbond_ene(i,j,k,evdwij)
25079 !c               if(evdwij_przed_tri.ne.evdwij) then
25080 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25081 !c               endif
25082
25083 !c              write(iout,*) "PO TRI", evdwij
25084 !C call the energy function that removes the artifical triple disulfide
25085 !C bond the soubroutine is located in ssMD.F
25086               evdw=evdw+evdwij
25087               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25088                             'evdw',i,j,evdwij,'tss'
25089               endif!dyn_ss_mask(k)
25090              enddo! k
25091             ELSE
25092 !el            ind=ind+1
25093             itypj=iabs(itype(j,1))
25094             if (itypj.eq.ntyp1) cycle
25095              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25096
25097 !             if (j.ne.78) cycle
25098 !            dscj_inv=dsc_inv(itypj)
25099             dscj_inv=vbld_inv(j+nres)
25100            xj=c(1,j+nres)
25101            yj=c(2,j+nres)
25102            zj=c(3,j+nres)
25103            xj=dmod(xj,boxxsize)
25104            if (xj.lt.0) xj=xj+boxxsize
25105            yj=dmod(yj,boxysize)
25106            if (yj.lt.0) yj=yj+boxysize
25107            zj=dmod(zj,boxzsize)
25108            if (zj.lt.0) zj=zj+boxzsize
25109           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25110           xj_safe=xj
25111           yj_safe=yj
25112           zj_safe=zj
25113           subchap=0
25114
25115           do xshift=-1,1
25116           do yshift=-1,1
25117           do zshift=-1,1
25118           xj=xj_safe+xshift*boxxsize
25119           yj=yj_safe+yshift*boxysize
25120           zj=zj_safe+zshift*boxzsize
25121           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25122           if(dist_temp.lt.dist_init) then
25123             dist_init=dist_temp
25124             xj_temp=xj
25125             yj_temp=yj
25126             zj_temp=zj
25127             subchap=1
25128           endif
25129           enddo
25130           enddo
25131           enddo
25132           if (subchap.eq.1) then
25133           xj=xj_temp-xi
25134           yj=yj_temp-yi
25135           zj=zj_temp-zi
25136           else
25137           xj=xj_safe-xi
25138           yj=yj_safe-yi
25139           zj=zj_safe-zi
25140           endif
25141           dxj = dc_norm( 1, nres+j )
25142           dyj = dc_norm( 2, nres+j )
25143           dzj = dc_norm( 3, nres+j )
25144 !          print *,i,j,itypi,itypj
25145 !          d1i=0.0d0
25146 !          d1j=0.0d0
25147 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25148 ! Gay-berne var's
25149 !1!          sig0ij = sigma_scsc( itypi,itypj )
25150 !          chi1=0.0d0
25151 !          chi2=0.0d0
25152 !          chip1=0.0d0
25153 !          chip2=0.0d0
25154 ! not used by momo potential, but needed by sc_angular which is shared
25155 ! by all energy_potential subroutines
25156           alf1   = 0.0d0
25157           alf2   = 0.0d0
25158           alf12  = 0.0d0
25159           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25160 !       a12sq = a12sq * a12sq
25161 ! charge of amino acid itypi is...
25162           chis1 = chis(itypi,itypj)
25163           chis2 = chis(itypj,itypi)
25164           chis12 = chis1 * chis2
25165           sig1 = sigmap1(itypi,itypj)
25166           sig2 = sigmap2(itypi,itypj)
25167 !       write (*,*) "sig1 = ", sig1
25168 !          chis1=0.0
25169 !          chis2=0.0
25170 !                    chis12 = chis1 * chis2
25171 !          sig1=0.0
25172 !          sig2=0.0
25173 !       write (*,*) "sig2 = ", sig2
25174 ! alpha factors from Fcav/Gcav
25175           b1cav = alphasur(1,itypi,itypj)
25176 !          b1cav=0.0d0
25177           b2cav = alphasur(2,itypi,itypj)
25178           b3cav = alphasur(3,itypi,itypj)
25179           b4cav = alphasur(4,itypi,itypj)
25180 ! used to determine whether we want to do quadrupole calculations
25181        eps_in = epsintab(itypi,itypj)
25182        if (eps_in.eq.0.0) eps_in=1.0
25183
25184        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25185        Rtail = 0.0d0
25186 !       dtail(1,itypi,itypj)=0.0
25187 !       dtail(2,itypi,itypj)=0.0
25188
25189        DO k = 1, 3
25190         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25191         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25192        END DO
25193 !c! tail distances will be themselves usefull elswhere
25194 !c1 (in Gcav, for example)
25195        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25196        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25197        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25198        Rtail = dsqrt( &
25199           (Rtail_distance(1)*Rtail_distance(1)) &
25200         + (Rtail_distance(2)*Rtail_distance(2)) &
25201         + (Rtail_distance(3)*Rtail_distance(3)))
25202
25203 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25204 !-------------------------------------------------------------------
25205 ! tail location and distance calculations
25206        d1 = dhead(1, 1, itypi, itypj)
25207        d2 = dhead(2, 1, itypi, itypj)
25208
25209        DO k = 1,3
25210 ! location of polar head is computed by taking hydrophobic centre
25211 ! and moving by a d1 * dc_norm vector
25212 ! see unres publications for very informative images
25213         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25214         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25215 ! distance
25216 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25217 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25218         Rhead_distance(k) = chead(k,2) - chead(k,1)
25219        END DO
25220 ! pitagoras (root of sum of squares)
25221        Rhead = dsqrt( &
25222           (Rhead_distance(1)*Rhead_distance(1)) &
25223         + (Rhead_distance(2)*Rhead_distance(2)) &
25224         + (Rhead_distance(3)*Rhead_distance(3)))
25225 !-------------------------------------------------------------------
25226 ! zero everything that should be zero'ed
25227        evdwij = 0.0d0
25228        ECL = 0.0d0
25229        Elj = 0.0d0
25230        Equad = 0.0d0
25231        Epol = 0.0d0
25232        Fcav=0.0d0
25233        eheadtail = 0.0d0
25234        dGCLdOM1 = 0.0d0
25235        dGCLdOM2 = 0.0d0
25236        dGCLdOM12 = 0.0d0
25237        dPOLdOM1 = 0.0d0
25238        dPOLdOM2 = 0.0d0
25239           Fcav = 0.0d0
25240           dFdR = 0.0d0
25241           dCAVdOM1  = 0.0d0
25242           dCAVdOM2  = 0.0d0
25243           dCAVdOM12 = 0.0d0
25244           dscj_inv = vbld_inv(j+nres)
25245 !          print *,i,j,dscj_inv,dsci_inv
25246 ! rij holds 1/(distance of Calpha atoms)
25247           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25248           rij  = dsqrt(rrij)
25249 !----------------------------
25250           CALL sc_angular
25251 ! this should be in elgrad_init but om's are calculated by sc_angular
25252 ! which in turn is used by older potentials
25253 ! om = omega, sqom = om^2
25254           sqom1  = om1 * om1
25255           sqom2  = om2 * om2
25256           sqom12 = om12 * om12
25257
25258 ! now we calculate EGB - Gey-Berne
25259 ! It will be summed up in evdwij and saved in evdw
25260           sigsq     = 1.0D0  / sigsq
25261           sig       = sig0ij * dsqrt(sigsq)
25262 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25263           rij_shift = Rtail - sig + sig0ij
25264           IF (rij_shift.le.0.0D0) THEN
25265            evdw = 1.0D20
25266            RETURN
25267           END IF
25268           sigder = -sig * sigsq
25269           rij_shift = 1.0D0 / rij_shift
25270           fac       = rij_shift**expon
25271           c1        = fac  * fac * aa_aq(itypi,itypj)
25272 !          print *,"ADAM",aa_aq(itypi,itypj)
25273
25274 !          c1        = 0.0d0
25275           c2        = fac  * bb_aq(itypi,itypj)
25276 !          c2        = 0.0d0
25277           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25278           eps2der   = eps3rt * evdwij
25279           eps3der   = eps2rt * evdwij
25280 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25281           evdwij    = eps2rt * eps3rt * evdwij
25282 !#ifdef TSCSC
25283 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25284 !           evdw_p = evdw_p + evdwij
25285 !          ELSE
25286 !           evdw_m = evdw_m + evdwij
25287 !          END IF
25288 !#else
25289           evdw = evdw  &
25290               + evdwij
25291 !#endif
25292
25293           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25294           fac    = -expon * (c1 + evdwij) * rij_shift
25295           sigder = fac * sigder
25296 !          fac    = rij * fac
25297 ! Calculate distance derivative
25298           gg(1) =  fac
25299           gg(2) =  fac
25300           gg(3) =  fac
25301 !          if (b2.gt.0.0) then
25302           fac = chis1 * sqom1 + chis2 * sqom2 &
25303           - 2.0d0 * chis12 * om1 * om2 * om12
25304 ! we will use pom later in Gcav, so dont mess with it!
25305           pom = 1.0d0 - chis1 * chis2 * sqom12
25306           Lambf = (1.0d0 - (fac / pom))
25307 !          print *,"fac,pom",fac,pom,Lambf
25308           Lambf = dsqrt(Lambf)
25309           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25310 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25311 !       write (*,*) "sparrow = ", sparrow
25312           Chif = Rtail * sparrow
25313 !           print *,"rij,sparrow",rij , sparrow
25314           ChiLambf = Chif * Lambf
25315           eagle = dsqrt(ChiLambf)
25316           bat = ChiLambf ** 11.0d0
25317           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25318           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25319           botsq = bot * bot
25320 !          print *,top,bot,"bot,top",ChiLambf,Chif
25321           Fcav = top / bot
25322
25323        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25324        dbot = 12.0d0 * b4cav * bat * Lambf
25325        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25326
25327           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25328           dbot = 12.0d0 * b4cav * bat * Chif
25329           eagle = Lambf * pom
25330           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25331           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25332           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25333               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25334
25335           dFdL = ((dtop * bot - top * dbot) / botsq)
25336 !       dFdL = 0.0d0
25337           dCAVdOM1  = dFdL * ( dFdOM1 )
25338           dCAVdOM2  = dFdL * ( dFdOM2 )
25339           dCAVdOM12 = dFdL * ( dFdOM12 )
25340
25341        DO k= 1, 3
25342         ertail(k) = Rtail_distance(k)/Rtail
25343        END DO
25344        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25345        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25346        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25347        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25348        DO k = 1, 3
25349 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25350 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25351         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25352         gvdwx(k,i) = gvdwx(k,i) &
25353                   - (( dFdR + gg(k) ) * pom)
25354 !c!     &             - ( dFdR * pom )
25355         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25356         gvdwx(k,j) = gvdwx(k,j)   &
25357                   + (( dFdR + gg(k) ) * pom)
25358 !c!     &             + ( dFdR * pom )
25359
25360         gvdwc(k,i) = gvdwc(k,i)  &
25361                   - (( dFdR + gg(k) ) * ertail(k))
25362 !c!     &             - ( dFdR * ertail(k))
25363
25364         gvdwc(k,j) = gvdwc(k,j) &
25365                   + (( dFdR + gg(k) ) * ertail(k))
25366 !c!     &             + ( dFdR * ertail(k))
25367
25368         gg(k) = 0.0d0
25369 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25370 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25371       END DO
25372
25373
25374 !c! Compute head-head and head-tail energies for each state
25375
25376           isel = iabs(Qi) + iabs(Qj)
25377 ! double charge for Phophorylated! itype - 25,27,27
25378 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25379 !            Qi=Qi*2
25380 !            Qij=Qij*2
25381 !           endif
25382 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25383 !            Qj=Qj*2
25384 !            Qij=Qij*2
25385 !           endif
25386
25387 !          isel=0
25388           IF (isel.eq.0) THEN
25389 !c! No charges - do nothing
25390            eheadtail = 0.0d0
25391
25392           ELSE IF (isel.eq.4) THEN
25393 !c! Calculate dipole-dipole interactions
25394            CALL edd(ecl)
25395            eheadtail = ECL
25396 !           eheadtail = 0.0d0
25397
25398           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25399 !c! Charge-nonpolar interactions
25400           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25401             Qi=Qi*2
25402             Qij=Qij*2
25403            endif
25404           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25405             Qj=Qj*2
25406             Qij=Qij*2
25407            endif
25408
25409            CALL eqn(epol)
25410            eheadtail = epol
25411 !           eheadtail = 0.0d0
25412
25413           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25414 !c! Nonpolar-charge interactions
25415           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25416             Qi=Qi*2
25417             Qij=Qij*2
25418            endif
25419           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25420             Qj=Qj*2
25421             Qij=Qij*2
25422            endif
25423
25424            CALL enq(epol)
25425            eheadtail = epol
25426 !           eheadtail = 0.0d0
25427
25428           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25429 !c! Charge-dipole interactions
25430           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25431             Qi=Qi*2
25432             Qij=Qij*2
25433            endif
25434           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25435             Qj=Qj*2
25436             Qij=Qij*2
25437            endif
25438
25439            CALL eqd(ecl, elj, epol)
25440            eheadtail = ECL + elj + epol
25441 !           eheadtail = 0.0d0
25442
25443           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25444 !c! Dipole-charge interactions
25445           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25446             Qi=Qi*2
25447             Qij=Qij*2
25448            endif
25449           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25450             Qj=Qj*2
25451             Qij=Qij*2
25452            endif
25453            CALL edq(ecl, elj, epol)
25454           eheadtail = ECL + elj + epol
25455 !           eheadtail = 0.0d0
25456
25457           ELSE IF ((isel.eq.2.and.   &
25458                iabs(Qi).eq.1).and.  &
25459                nstate(itypi,itypj).eq.1) THEN
25460 !c! Same charge-charge interaction ( +/+ or -/- )
25461           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25462             Qi=Qi*2
25463             Qij=Qij*2
25464            endif
25465           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25466             Qj=Qj*2
25467             Qij=Qij*2
25468            endif
25469
25470            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25471            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25472 !           eheadtail = 0.0d0
25473
25474           ELSE IF ((isel.eq.2.and.  &
25475                iabs(Qi).eq.1).and. &
25476                nstate(itypi,itypj).ne.1) THEN
25477 !c! Different charge-charge interaction ( +/- or -/+ )
25478           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25479             Qi=Qi*2
25480             Qij=Qij*2
25481            endif
25482           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25483             Qj=Qj*2
25484             Qij=Qij*2
25485            endif
25486
25487            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25488           END IF
25489        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25490       evdw = evdw  + Fcav + eheadtail
25491
25492        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25493         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25494         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25495         Equad,evdwij+Fcav+eheadtail,evdw
25496 !       evdw = evdw  + Fcav  + eheadtail
25497
25498         iF (nstate(itypi,itypj).eq.1) THEN
25499         CALL sc_grad
25500        END IF
25501 !c!-------------------------------------------------------------------
25502 !c! NAPISY KONCOWE
25503          END DO   ! j
25504         END DO    ! iint
25505        END DO     ! i
25506 !c      write (iout,*) "Number of loop steps in EGB:",ind
25507 !c      energy_dec=.false.
25508 !              print *,"EVDW KURW",evdw,nres
25509
25510        RETURN
25511       END SUBROUTINE emomo
25512 !C------------------------------------------------------------------------------------
25513       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25514       use calc_data
25515       use comm_momo
25516        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25517          Ecl,Egb,Epol,Fisocav,Elj,Fgb
25518 !       integer :: k
25519 !c! Epol and Gpol analytical parameters
25520        alphapol1 = alphapol(itypi,itypj)
25521        alphapol2 = alphapol(itypj,itypi)
25522 !c! Fisocav and Gisocav analytical parameters
25523        al1  = alphiso(1,itypi,itypj)
25524        al2  = alphiso(2,itypi,itypj)
25525        al3  = alphiso(3,itypi,itypj)
25526        al4  = alphiso(4,itypi,itypj)
25527        csig = (1.0d0  &
25528            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25529            + sigiso2(itypi,itypj)**2.0d0))
25530 !c!
25531        pis  = sig0head(itypi,itypj)
25532        eps_head = epshead(itypi,itypj)
25533        Rhead_sq = Rhead * Rhead
25534 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25535 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25536        R1 = 0.0d0
25537        R2 = 0.0d0
25538        DO k = 1, 3
25539 !c! Calculate head-to-tail distances needed by Epol
25540         R1=R1+(ctail(k,2)-chead(k,1))**2
25541         R2=R2+(chead(k,2)-ctail(k,1))**2
25542        END DO
25543 !c! Pitagoras
25544        R1 = dsqrt(R1)
25545        R2 = dsqrt(R2)
25546
25547 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25548 !c!     &        +dhead(1,1,itypi,itypj))**2))
25549 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25550 !c!     &        +dhead(2,1,itypi,itypj))**2))
25551
25552 !c!-------------------------------------------------------------------
25553 !c! Coulomb electrostatic interaction
25554        Ecl = (332.0d0 * Qij) / Rhead
25555 !c! derivative of Ecl is Gcl...
25556        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25557        dGCLdOM1 = 0.0d0
25558        dGCLdOM2 = 0.0d0
25559        dGCLdOM12 = 0.0d0
25560        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25561        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25562        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25563 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25564 !c! Derivative of Egb is Ggb...
25565        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25566        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25567        dGGBdR = dGGBdFGB * dFGBdR
25568 !c!-------------------------------------------------------------------
25569 !c! Fisocav - isotropic cavity creation term
25570 !c! or "how much energy it costs to put charged head in water"
25571        pom = Rhead * csig
25572        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25573        bot = (1.0d0 + al4 * pom**12.0d0)
25574        botsq = bot * bot
25575        FisoCav = top / bot
25576 !      write (*,*) "Rhead = ",Rhead
25577 !      write (*,*) "csig = ",csig
25578 !      write (*,*) "pom = ",pom
25579 !      write (*,*) "al1 = ",al1
25580 !      write (*,*) "al2 = ",al2
25581 !      write (*,*) "al3 = ",al3
25582 !      write (*,*) "al4 = ",al4
25583 !        write (*,*) "top = ",top
25584 !        write (*,*) "bot = ",bot
25585 !c! Derivative of Fisocav is GCV...
25586        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25587        dbot = 12.0d0 * al4 * pom ** 11.0d0
25588        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25589 !c!-------------------------------------------------------------------
25590 !c! Epol
25591 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25592        MomoFac1 = (1.0d0 - chi1 * sqom2)
25593        MomoFac2 = (1.0d0 - chi2 * sqom1)
25594        RR1  = ( R1 * R1 ) / MomoFac1
25595        RR2  = ( R2 * R2 ) / MomoFac2
25596        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25597        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25598        fgb1 = sqrt( RR1 + a12sq * ee1 )
25599        fgb2 = sqrt( RR2 + a12sq * ee2 )
25600        epol = 332.0d0 * eps_inout_fac * ( &
25601       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25602 !c!       epol = 0.0d0
25603        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25604                / (fgb1 ** 5.0d0)
25605        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25606                / (fgb2 ** 5.0d0)
25607        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25608              / ( 2.0d0 * fgb1 )
25609        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25610              / ( 2.0d0 * fgb2 )
25611        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25612                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25613        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25614                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25615        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25616 !c!       dPOLdR1 = 0.0d0
25617        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25618 !c!       dPOLdR2 = 0.0d0
25619        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25620 !c!       dPOLdOM1 = 0.0d0
25621        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25622 !c!       dPOLdOM2 = 0.0d0
25623 !c!-------------------------------------------------------------------
25624 !c! Elj
25625 !c! Lennard-Jones 6-12 interaction between heads
25626        pom = (pis / Rhead)**6.0d0
25627        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25628 !c! derivative of Elj is Glj
25629        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25630              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25631 !c!-------------------------------------------------------------------
25632 !c! Return the results
25633 !c! These things do the dRdX derivatives, that is
25634 !c! allow us to change what we see from function that changes with
25635 !c! distance to function that changes with LOCATION (of the interaction
25636 !c! site)
25637        DO k = 1, 3
25638         erhead(k) = Rhead_distance(k)/Rhead
25639         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25640         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25641        END DO
25642
25643        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25644        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25645        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25646        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25647        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25648        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25649        facd1 = d1 * vbld_inv(i+nres)
25650        facd2 = d2 * vbld_inv(j+nres)
25651        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25652        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25653
25654 !c! Now we add appropriate partial derivatives (one in each dimension)
25655        DO k = 1, 3
25656         hawk   = (erhead_tail(k,1) + &
25657         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25658         condor = (erhead_tail(k,2) + &
25659         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25660
25661         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25662         gvdwx(k,i) = gvdwx(k,i) &
25663                   - dGCLdR * pom&
25664                   - dGGBdR * pom&
25665                   - dGCVdR * pom&
25666                   - dPOLdR1 * hawk&
25667                   - dPOLdR2 * (erhead_tail(k,2)&
25668       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25669                   - dGLJdR * pom
25670
25671         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25672         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25673                    + dGGBdR * pom+ dGCVdR * pom&
25674                   + dPOLdR1 * (erhead_tail(k,1)&
25675       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25676                   + dPOLdR2 * condor + dGLJdR * pom
25677
25678         gvdwc(k,i) = gvdwc(k,i)  &
25679                   - dGCLdR * erhead(k)&
25680                   - dGGBdR * erhead(k)&
25681                   - dGCVdR * erhead(k)&
25682                   - dPOLdR1 * erhead_tail(k,1)&
25683                   - dPOLdR2 * erhead_tail(k,2)&
25684                   - dGLJdR * erhead(k)
25685
25686         gvdwc(k,j) = gvdwc(k,j)         &
25687                   + dGCLdR * erhead(k) &
25688                   + dGGBdR * erhead(k) &
25689                   + dGCVdR * erhead(k) &
25690                   + dPOLdR1 * erhead_tail(k,1) &
25691                   + dPOLdR2 * erhead_tail(k,2)&
25692                   + dGLJdR * erhead(k)
25693
25694        END DO
25695        RETURN
25696       END SUBROUTINE eqq
25697 !c!-------------------------------------------------------------------
25698       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25699       use comm_momo
25700       use calc_data
25701
25702        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
25703        double precision ener(4)
25704        double precision dcosom1(3),dcosom2(3)
25705 !c! used in Epol derivatives
25706        double precision facd3, facd4
25707        double precision federmaus, adler
25708        integer istate,ii,jj
25709        real (kind=8) :: Fgb
25710 !       print *,"CALLING EQUAD"
25711 !c! Epol and Gpol analytical parameters
25712        alphapol1 = alphapol(itypi,itypj)
25713        alphapol2 = alphapol(itypj,itypi)
25714 !c! Fisocav and Gisocav analytical parameters
25715        al1  = alphiso(1,itypi,itypj)
25716        al2  = alphiso(2,itypi,itypj)
25717        al3  = alphiso(3,itypi,itypj)
25718        al4  = alphiso(4,itypi,itypj)
25719        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25720             + sigiso2(itypi,itypj)**2.0d0))
25721 !c!
25722        w1   = wqdip(1,itypi,itypj)
25723        w2   = wqdip(2,itypi,itypj)
25724        pis  = sig0head(itypi,itypj)
25725        eps_head = epshead(itypi,itypj)
25726 !c! First things first:
25727 !c! We need to do sc_grad's job with GB and Fcav
25728        eom1  = eps2der * eps2rt_om1 &
25729              - 2.0D0 * alf1 * eps3der&
25730              + sigder * sigsq_om1&
25731              + dCAVdOM1
25732        eom2  = eps2der * eps2rt_om2 &
25733              + 2.0D0 * alf2 * eps3der&
25734              + sigder * sigsq_om2&
25735              + dCAVdOM2
25736        eom12 =  evdwij  * eps1_om12 &
25737              + eps2der * eps2rt_om12 &
25738              - 2.0D0 * alf12 * eps3der&
25739              + sigder *sigsq_om12&
25740              + dCAVdOM12
25741 !c! now some magical transformations to project gradient into
25742 !c! three cartesian vectors
25743        DO k = 1, 3
25744         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25745         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25746         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25747 !c! this acts on hydrophobic center of interaction
25748         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25749                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25750                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25751         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25752                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25753                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25754 !c! this acts on Calpha
25755         gvdwc(k,i)=gvdwc(k,i)-gg(k)
25756         gvdwc(k,j)=gvdwc(k,j)+gg(k)
25757        END DO
25758 !c! sc_grad is done, now we will compute
25759        eheadtail = 0.0d0
25760        eom1 = 0.0d0
25761        eom2 = 0.0d0
25762        eom12 = 0.0d0
25763        DO istate = 1, nstate(itypi,itypj)
25764 !c*************************************************************
25765         IF (istate.ne.1) THEN
25766          IF (istate.lt.3) THEN
25767           ii = 1
25768          ELSE
25769           ii = 2
25770          END IF
25771         jj = istate/ii
25772         d1 = dhead(1,ii,itypi,itypj)
25773         d2 = dhead(2,jj,itypi,itypj)
25774         DO k = 1,3
25775          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25776          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25777          Rhead_distance(k) = chead(k,2) - chead(k,1)
25778         END DO
25779 !c! pitagoras (root of sum of squares)
25780         Rhead = dsqrt( &
25781                (Rhead_distance(1)*Rhead_distance(1))  &
25782              + (Rhead_distance(2)*Rhead_distance(2))  &
25783              + (Rhead_distance(3)*Rhead_distance(3)))
25784         END IF
25785         Rhead_sq = Rhead * Rhead
25786
25787 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25788 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25789         R1 = 0.0d0
25790         R2 = 0.0d0
25791         DO k = 1, 3
25792 !c! Calculate head-to-tail distances
25793          R1=R1+(ctail(k,2)-chead(k,1))**2
25794          R2=R2+(chead(k,2)-ctail(k,1))**2
25795         END DO
25796 !c! Pitagoras
25797         R1 = dsqrt(R1)
25798         R2 = dsqrt(R2)
25799         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25800 !c!        Ecl = 0.0d0
25801 !c!        write (*,*) "Ecl = ", Ecl
25802 !c! derivative of Ecl is Gcl...
25803         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25804 !c!        dGCLdR = 0.0d0
25805         dGCLdOM1 = 0.0d0
25806         dGCLdOM2 = 0.0d0
25807         dGCLdOM12 = 0.0d0
25808 !c!-------------------------------------------------------------------
25809 !c! Generalised Born Solvent Polarization
25810         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25811         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25812         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25813 !c!        Egb = 0.0d0
25814 !c!      write (*,*) "a1*a2 = ", a12sq
25815 !c!      write (*,*) "Rhead = ", Rhead
25816 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25817 !c!      write (*,*) "ee = ", ee
25818 !c!      write (*,*) "Fgb = ", Fgb
25819 !c!      write (*,*) "fac = ", eps_inout_fac
25820 !c!      write (*,*) "Qij = ", Qij
25821 !c!      write (*,*) "Egb = ", Egb
25822 !c! Derivative of Egb is Ggb...
25823 !c! dFGBdR is used by Quad's later...
25824         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25825         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25826                / ( 2.0d0 * Fgb )
25827         dGGBdR = dGGBdFGB * dFGBdR
25828 !c!        dGGBdR = 0.0d0
25829 !c!-------------------------------------------------------------------
25830 !c! Fisocav - isotropic cavity creation term
25831         pom = Rhead * csig
25832         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25833         bot = (1.0d0 + al4 * pom**12.0d0)
25834         botsq = bot * bot
25835         FisoCav = top / bot
25836         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25837         dbot = 12.0d0 * al4 * pom ** 11.0d0
25838         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25839 !c!        dGCVdR = 0.0d0
25840 !c!-------------------------------------------------------------------
25841 !c! Polarization energy
25842 !c! Epol
25843         MomoFac1 = (1.0d0 - chi1 * sqom2)
25844         MomoFac2 = (1.0d0 - chi2 * sqom1)
25845         RR1  = ( R1 * R1 ) / MomoFac1
25846         RR2  = ( R2 * R2 ) / MomoFac2
25847         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25848         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25849         fgb1 = sqrt( RR1 + a12sq * ee1 )
25850         fgb2 = sqrt( RR2 + a12sq * ee2 )
25851         epol = 332.0d0 * eps_inout_fac * (&
25852         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25853 !c!        epol = 0.0d0
25854 !c! derivative of Epol is Gpol...
25855         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25856                   / (fgb1 ** 5.0d0)
25857         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25858                   / (fgb2 ** 5.0d0)
25859         dFGBdR1 = ( (R1 / MomoFac1) &
25860                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25861                 / ( 2.0d0 * fgb1 )
25862         dFGBdR2 = ( (R2 / MomoFac2) &
25863                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25864                 / ( 2.0d0 * fgb2 )
25865         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25866                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25867                  / ( 2.0d0 * fgb1 )
25868         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25869                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25870                  / ( 2.0d0 * fgb2 )
25871         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25872 !c!        dPOLdR1 = 0.0d0
25873         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25874 !c!        dPOLdR2 = 0.0d0
25875         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25876 !c!        dPOLdOM1 = 0.0d0
25877         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25878         pom = (pis / Rhead)**6.0d0
25879         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25880 !c!        Elj = 0.0d0
25881 !c! derivative of Elj is Glj
25882         dGLJdR = 4.0d0 * eps_head &
25883             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25884             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25885 !c!        dGLJdR = 0.0d0
25886 !c!-------------------------------------------------------------------
25887 !c! Equad
25888        IF (Wqd.ne.0.0d0) THEN
25889         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25890              - 37.5d0  * ( sqom1 + sqom2 ) &
25891              + 157.5d0 * ( sqom1 * sqom2 ) &
25892              - 45.0d0  * om1*om2*om12
25893         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25894         Equad = fac * Beta1
25895 !c!        Equad = 0.0d0
25896 !c! derivative of Equad...
25897         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25898 !c!        dQUADdR = 0.0d0
25899         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25900 !c!        dQUADdOM1 = 0.0d0
25901         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25902 !c!        dQUADdOM2 = 0.0d0
25903         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25904        ELSE
25905          Beta1 = 0.0d0
25906          Equad = 0.0d0
25907         END IF
25908 !c!-------------------------------------------------------------------
25909 !c! Return the results
25910 !c! Angular stuff
25911         eom1 = dPOLdOM1 + dQUADdOM1
25912         eom2 = dPOLdOM2 + dQUADdOM2
25913         eom12 = dQUADdOM12
25914 !c! now some magical transformations to project gradient into
25915 !c! three cartesian vectors
25916         DO k = 1, 3
25917          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25918          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25919          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25920         END DO
25921 !c! Radial stuff
25922         DO k = 1, 3
25923          erhead(k) = Rhead_distance(k)/Rhead
25924          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25925          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25926         END DO
25927         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25928         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25929         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25930         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25931         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25932         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25933         facd1 = d1 * vbld_inv(i+nres)
25934         facd2 = d2 * vbld_inv(j+nres)
25935         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25936         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25937         DO k = 1, 3
25938          hawk   = erhead_tail(k,1) + &
25939          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25940          condor = erhead_tail(k,2) + &
25941          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25942
25943          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25944 !c! this acts on hydrophobic center of interaction
25945          gheadtail(k,1,1) = gheadtail(k,1,1) &
25946                          - dGCLdR * pom &
25947                          - dGGBdR * pom &
25948                          - dGCVdR * pom &
25949                          - dPOLdR1 * hawk &
25950                          - dPOLdR2 * (erhead_tail(k,2) &
25951       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25952                          - dGLJdR * pom &
25953                          - dQUADdR * pom&
25954                          - tuna(k) &
25955                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25956                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25957
25958          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25959 !c! this acts on hydrophobic center of interaction
25960          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25961                          + dGCLdR * pom      &
25962                          + dGGBdR * pom      &
25963                          + dGCVdR * pom      &
25964                          + dPOLdR1 * (erhead_tail(k,1) &
25965       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25966                          + dPOLdR2 * condor &
25967                          + dGLJdR * pom &
25968                          + dQUADdR * pom &
25969                          + tuna(k) &
25970                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25971                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25972
25973 !c! this acts on Calpha
25974          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25975                          - dGCLdR * erhead(k)&
25976                          - dGGBdR * erhead(k)&
25977                          - dGCVdR * erhead(k)&
25978                          - dPOLdR1 * erhead_tail(k,1)&
25979                          - dPOLdR2 * erhead_tail(k,2)&
25980                          - dGLJdR * erhead(k) &
25981                          - dQUADdR * erhead(k)&
25982                          - tuna(k)
25983 !c! this acts on Calpha
25984          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25985                           + dGCLdR * erhead(k) &
25986                           + dGGBdR * erhead(k) &
25987                           + dGCVdR * erhead(k) &
25988                           + dPOLdR1 * erhead_tail(k,1) &
25989                           + dPOLdR2 * erhead_tail(k,2) &
25990                           + dGLJdR * erhead(k) &
25991                           + dQUADdR * erhead(k)&
25992                           + tuna(k)
25993         END DO
25994         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25995         eheadtail = eheadtail &
25996                   + wstate(istate, itypi, itypj) &
25997                   * dexp(-betaT * ener(istate))
25998 !c! foreach cartesian dimension
25999         DO k = 1, 3
26000 !c! foreach of two gvdwx and gvdwc
26001          DO l = 1, 4
26002           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26003                            + wstate( istate, itypi, itypj ) &
26004                            * dexp(-betaT * ener(istate)) &
26005                            * gheadtail(k,l,1)
26006           gheadtail(k,l,1) = 0.0d0
26007          END DO
26008         END DO
26009        END DO
26010 !c! Here ended the gigantic DO istate = 1, 4, which starts
26011 !c! at the beggining of the subroutine
26012
26013        DO k = 1, 3
26014         DO l = 1, 4
26015          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26016         END DO
26017         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26018         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26019         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26020         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26021         DO l = 1, 4
26022          gheadtail(k,l,1) = 0.0d0
26023          gheadtail(k,l,2) = 0.0d0
26024         END DO
26025        END DO
26026        eheadtail = (-dlog(eheadtail)) / betaT
26027        dPOLdOM1 = 0.0d0
26028        dPOLdOM2 = 0.0d0
26029        dQUADdOM1 = 0.0d0
26030        dQUADdOM2 = 0.0d0
26031        dQUADdOM12 = 0.0d0
26032        RETURN
26033       END SUBROUTINE energy_quad
26034 !!-----------------------------------------------------------
26035       SUBROUTINE eqn(Epol)
26036       use comm_momo
26037       use calc_data
26038
26039       double precision  facd4, federmaus,epol
26040       alphapol1 = alphapol(itypi,itypj)
26041 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26042        R1 = 0.0d0
26043        DO k = 1, 3
26044 !c! Calculate head-to-tail distances
26045         R1=R1+(ctail(k,2)-chead(k,1))**2
26046        END DO
26047 !c! Pitagoras
26048        R1 = dsqrt(R1)
26049
26050 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26051 !c!     &        +dhead(1,1,itypi,itypj))**2))
26052 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26053 !c!     &        +dhead(2,1,itypi,itypj))**2))
26054 !c--------------------------------------------------------------------
26055 !c Polarization energy
26056 !c Epol
26057        MomoFac1 = (1.0d0 - chi1 * sqom2)
26058        RR1  = R1 * R1 / MomoFac1
26059        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26060        fgb1 = sqrt( RR1 + a12sq * ee1)
26061        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26062        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26063                / (fgb1 ** 5.0d0)
26064        dFGBdR1 = ( (R1 / MomoFac1) &
26065               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26066               / ( 2.0d0 * fgb1 )
26067        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26068                 * (2.0d0 - 0.5d0 * ee1) ) &
26069                 / (2.0d0 * fgb1)
26070        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26071 !c!       dPOLdR1 = 0.0d0
26072        dPOLdOM1 = 0.0d0
26073        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26074        DO k = 1, 3
26075         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26076        END DO
26077        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26078        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26079        facd1 = d1 * vbld_inv(i+nres)
26080        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26081
26082        DO k = 1, 3
26083         hawk = (erhead_tail(k,1) + &
26084         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26085
26086         gvdwx(k,i) = gvdwx(k,i) &
26087                    - dPOLdR1 * hawk
26088         gvdwx(k,j) = gvdwx(k,j) &
26089                    + dPOLdR1 * (erhead_tail(k,1) &
26090        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26091
26092         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26093         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26094
26095        END DO
26096        RETURN
26097       END SUBROUTINE eqn
26098       SUBROUTINE enq(Epol)
26099       use calc_data
26100       use comm_momo
26101        double precision facd3, adler,epol
26102        alphapol2 = alphapol(itypj,itypi)
26103 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26104        R2 = 0.0d0
26105        DO k = 1, 3
26106 !c! Calculate head-to-tail distances
26107         R2=R2+(chead(k,2)-ctail(k,1))**2
26108        END DO
26109 !c! Pitagoras
26110        R2 = dsqrt(R2)
26111
26112 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26113 !c!     &        +dhead(1,1,itypi,itypj))**2))
26114 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26115 !c!     &        +dhead(2,1,itypi,itypj))**2))
26116 !c------------------------------------------------------------------------
26117 !c Polarization energy
26118        MomoFac2 = (1.0d0 - chi2 * sqom1)
26119        RR2  = R2 * R2 / MomoFac2
26120        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26121        fgb2 = sqrt(RR2  + a12sq * ee2)
26122        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26123        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26124                 / (fgb2 ** 5.0d0)
26125        dFGBdR2 = ( (R2 / MomoFac2)  &
26126               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26127               / (2.0d0 * fgb2)
26128        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26129                 * (2.0d0 - 0.5d0 * ee2) ) &
26130                 / (2.0d0 * fgb2)
26131        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26132 !c!       dPOLdR2 = 0.0d0
26133        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26134 !c!       dPOLdOM1 = 0.0d0
26135        dPOLdOM2 = 0.0d0
26136 !c!-------------------------------------------------------------------
26137 !c! Return the results
26138 !c! (See comments in Eqq)
26139        DO k = 1, 3
26140         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26141        END DO
26142        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26143        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26144        facd2 = d2 * vbld_inv(j+nres)
26145        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26146        DO k = 1, 3
26147         condor = (erhead_tail(k,2) &
26148        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26149
26150         gvdwx(k,i) = gvdwx(k,i) &
26151                    - dPOLdR2 * (erhead_tail(k,2) &
26152        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26153         gvdwx(k,j) = gvdwx(k,j)   &
26154                    + dPOLdR2 * condor
26155
26156         gvdwc(k,i) = gvdwc(k,i) &
26157                    - dPOLdR2 * erhead_tail(k,2)
26158         gvdwc(k,j) = gvdwc(k,j) &
26159                    + dPOLdR2 * erhead_tail(k,2)
26160
26161        END DO
26162       RETURN
26163       END SUBROUTINE enq
26164       SUBROUTINE eqd(Ecl,Elj,Epol)
26165       use calc_data
26166       use comm_momo
26167        double precision  facd4, federmaus,ecl,elj,epol
26168        alphapol1 = alphapol(itypi,itypj)
26169        w1        = wqdip(1,itypi,itypj)
26170        w2        = wqdip(2,itypi,itypj)
26171        pis       = sig0head(itypi,itypj)
26172        eps_head   = epshead(itypi,itypj)
26173 !c!-------------------------------------------------------------------
26174 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26175        R1 = 0.0d0
26176        DO k = 1, 3
26177 !c! Calculate head-to-tail distances
26178         R1=R1+(ctail(k,2)-chead(k,1))**2
26179        END DO
26180 !c! Pitagoras
26181        R1 = dsqrt(R1)
26182
26183 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26184 !c!     &        +dhead(1,1,itypi,itypj))**2))
26185 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26186 !c!     &        +dhead(2,1,itypi,itypj))**2))
26187
26188 !c!-------------------------------------------------------------------
26189 !c! ecl
26190        sparrow  = w1 * Qi * om1
26191        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26192        Ecl = sparrow / Rhead**2.0d0 &
26193            - hawk    / Rhead**4.0d0
26194        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26195                  + 4.0d0 * hawk    / Rhead**5.0d0
26196 !c! dF/dom1
26197        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26198 !c! dF/dom2
26199        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26200 !c--------------------------------------------------------------------
26201 !c Polarization energy
26202 !c Epol
26203        MomoFac1 = (1.0d0 - chi1 * sqom2)
26204        RR1  = R1 * R1 / MomoFac1
26205        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26206        fgb1 = sqrt( RR1 + a12sq * ee1)
26207        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26208 !c!       epol = 0.0d0
26209 !c!------------------------------------------------------------------
26210 !c! derivative of Epol is Gpol...
26211        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26212                / (fgb1 ** 5.0d0)
26213        dFGBdR1 = ( (R1 / MomoFac1)  &
26214              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26215              / ( 2.0d0 * fgb1 )
26216        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26217                * (2.0d0 - 0.5d0 * ee1) ) &
26218                / (2.0d0 * fgb1)
26219        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26220 !c!       dPOLdR1 = 0.0d0
26221        dPOLdOM1 = 0.0d0
26222        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26223 !c!       dPOLdOM2 = 0.0d0
26224 !c!-------------------------------------------------------------------
26225 !c! Elj
26226        pom = (pis / Rhead)**6.0d0
26227        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26228 !c! derivative of Elj is Glj
26229        dGLJdR = 4.0d0 * eps_head &
26230           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26231           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26232        DO k = 1, 3
26233         erhead(k) = Rhead_distance(k)/Rhead
26234         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26235        END DO
26236
26237        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26238        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26239        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26240        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26241        facd1 = d1 * vbld_inv(i+nres)
26242        facd2 = d2 * vbld_inv(j+nres)
26243        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26244
26245        DO k = 1, 3
26246         hawk = (erhead_tail(k,1) +  &
26247         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26248
26249         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26250         gvdwx(k,i) = gvdwx(k,i)  &
26251                    - dGCLdR * pom&
26252                    - dPOLdR1 * hawk &
26253                    - dGLJdR * pom
26254
26255         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26256         gvdwx(k,j) = gvdwx(k,j)    &
26257                    + dGCLdR * pom  &
26258                    + dPOLdR1 * (erhead_tail(k,1) &
26259        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26260                    + dGLJdR * pom
26261
26262
26263         gvdwc(k,i) = gvdwc(k,i)          &
26264                    - dGCLdR * erhead(k)  &
26265                    - dPOLdR1 * erhead_tail(k,1) &
26266                    - dGLJdR * erhead(k)
26267
26268         gvdwc(k,j) = gvdwc(k,j)          &
26269                    + dGCLdR * erhead(k)  &
26270                    + dPOLdR1 * erhead_tail(k,1) &
26271                    + dGLJdR * erhead(k)
26272
26273        END DO
26274        RETURN
26275       END SUBROUTINE eqd
26276       SUBROUTINE edq(Ecl,Elj,Epol)
26277 !       IMPLICIT NONE
26278        use comm_momo
26279       use calc_data
26280
26281       double precision  facd3, adler,ecl,elj,epol
26282        alphapol2 = alphapol(itypj,itypi)
26283        w1        = wqdip(1,itypi,itypj)
26284        w2        = wqdip(2,itypi,itypj)
26285        pis       = sig0head(itypi,itypj)
26286        eps_head  = epshead(itypi,itypj)
26287 !c!-------------------------------------------------------------------
26288 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26289        R2 = 0.0d0
26290        DO k = 1, 3
26291 !c! Calculate head-to-tail distances
26292         R2=R2+(chead(k,2)-ctail(k,1))**2
26293        END DO
26294 !c! Pitagoras
26295        R2 = dsqrt(R2)
26296
26297 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26298 !c!     &        +dhead(1,1,itypi,itypj))**2))
26299 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26300 !c!     &        +dhead(2,1,itypi,itypj))**2))
26301
26302
26303 !c!-------------------------------------------------------------------
26304 !c! ecl
26305        sparrow  = w1 * Qi * om1
26306        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26307        ECL = sparrow / Rhead**2.0d0 &
26308            - hawk    / Rhead**4.0d0
26309 !c!-------------------------------------------------------------------
26310 !c! derivative of ecl is Gcl
26311 !c! dF/dr part
26312        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26313                  + 4.0d0 * hawk    / Rhead**5.0d0
26314 !c! dF/dom1
26315        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26316 !c! dF/dom2
26317        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26318 !c--------------------------------------------------------------------
26319 !c Polarization energy
26320 !c Epol
26321        MomoFac2 = (1.0d0 - chi2 * sqom1)
26322        RR2  = R2 * R2 / MomoFac2
26323        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26324        fgb2 = sqrt(RR2  + a12sq * ee2)
26325        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26326        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26327                / (fgb2 ** 5.0d0)
26328        dFGBdR2 = ( (R2 / MomoFac2)  &
26329                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26330                / (2.0d0 * fgb2)
26331        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26332                 * (2.0d0 - 0.5d0 * ee2) ) &
26333                 / (2.0d0 * fgb2)
26334        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26335 !c!       dPOLdR2 = 0.0d0
26336        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26337 !c!       dPOLdOM1 = 0.0d0
26338        dPOLdOM2 = 0.0d0
26339 !c!-------------------------------------------------------------------
26340 !c! Elj
26341        pom = (pis / Rhead)**6.0d0
26342        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26343 !c! derivative of Elj is Glj
26344        dGLJdR = 4.0d0 * eps_head &
26345            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26346            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26347 !c!-------------------------------------------------------------------
26348 !c! Return the results
26349 !c! (see comments in Eqq)
26350        DO k = 1, 3
26351         erhead(k) = Rhead_distance(k)/Rhead
26352         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26353        END DO
26354        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26355        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26356        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26357        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26358        facd1 = d1 * vbld_inv(i+nres)
26359        facd2 = d2 * vbld_inv(j+nres)
26360        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26361        DO k = 1, 3
26362         condor = (erhead_tail(k,2) &
26363        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26364
26365         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26366         gvdwx(k,i) = gvdwx(k,i) &
26367                   - dGCLdR * pom &
26368                   - dPOLdR2 * (erhead_tail(k,2) &
26369        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26370                   - dGLJdR * pom
26371
26372         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26373         gvdwx(k,j) = gvdwx(k,j) &
26374                   + dGCLdR * pom &
26375                   + dPOLdR2 * condor &
26376                   + dGLJdR * pom
26377
26378
26379         gvdwc(k,i) = gvdwc(k,i) &
26380                   - dGCLdR * erhead(k) &
26381                   - dPOLdR2 * erhead_tail(k,2) &
26382                   - dGLJdR * erhead(k)
26383
26384         gvdwc(k,j) = gvdwc(k,j) &
26385                   + dGCLdR * erhead(k) &
26386                   + dPOLdR2 * erhead_tail(k,2) &
26387                   + dGLJdR * erhead(k)
26388
26389        END DO
26390        RETURN
26391       END SUBROUTINE edq
26392       SUBROUTINE edd(ECL)
26393 !       IMPLICIT NONE
26394        use comm_momo
26395       use calc_data
26396
26397        double precision ecl
26398 !c!       csig = sigiso(itypi,itypj)
26399        w1 = wqdip(1,itypi,itypj)
26400        w2 = wqdip(2,itypi,itypj)
26401 !c!-------------------------------------------------------------------
26402 !c! ECL
26403        fac = (om12 - 3.0d0 * om1 * om2)
26404        c1 = (w1 / (Rhead**3.0d0)) * fac
26405        c2 = (w2 / Rhead ** 6.0d0) &
26406           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26407        ECL = c1 - c2
26408 !c!       write (*,*) "w1 = ", w1
26409 !c!       write (*,*) "w2 = ", w2
26410 !c!       write (*,*) "om1 = ", om1
26411 !c!       write (*,*) "om2 = ", om2
26412 !c!       write (*,*) "om12 = ", om12
26413 !c!       write (*,*) "fac = ", fac
26414 !c!       write (*,*) "c1 = ", c1
26415 !c!       write (*,*) "c2 = ", c2
26416 !c!       write (*,*) "Ecl = ", Ecl
26417 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
26418 !c!       write (*,*) "c2_2 = ",
26419 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26420 !c!-------------------------------------------------------------------
26421 !c! dervative of ECL is GCL...
26422 !c! dECL/dr
26423        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26424        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26425           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26426        dGCLdR = c1 - c2
26427 !c! dECL/dom1
26428        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26429        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26430           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26431        dGCLdOM1 = c1 - c2
26432 !c! dECL/dom2
26433        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26434        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26435           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26436        dGCLdOM2 = c1 - c2
26437 !c! dECL/dom12
26438        c1 = w1 / (Rhead ** 3.0d0)
26439        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26440        dGCLdOM12 = c1 - c2
26441 !c!-------------------------------------------------------------------
26442 !c! Return the results
26443 !c! (see comments in Eqq)
26444        DO k= 1, 3
26445         erhead(k) = Rhead_distance(k)/Rhead
26446        END DO
26447        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26448        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26449        facd1 = d1 * vbld_inv(i+nres)
26450        facd2 = d2 * vbld_inv(j+nres)
26451        DO k = 1, 3
26452
26453         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26454         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
26455         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26456         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
26457
26458         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
26459         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
26460        END DO
26461        RETURN
26462       END SUBROUTINE edd
26463       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26464 !       IMPLICIT NONE
26465        use comm_momo
26466       use calc_data
26467
26468        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
26469        eps_out=80.0d0
26470        itypi = itype(i,1)
26471        itypj = itype(j,1)
26472 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
26473 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
26474 !c!       t_bath = 300
26475 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
26476        Rb=0.001986d0
26477        BetaT = 1.0d0 / (298.0d0 * Rb)
26478 !c! Gay-berne var's
26479        sig0ij = sigma( itypi,itypj )
26480        chi1   = chi( itypi, itypj )
26481        chi2   = chi( itypj, itypi )
26482        chi12  = chi1 * chi2
26483        chip1  = chipp( itypi, itypj )
26484        chip2  = chipp( itypj, itypi )
26485        chip12 = chip1 * chip2
26486 !       chi1=0.0
26487 !       chi2=0.0
26488 !       chi12=0.0
26489 !       chip1=0.0
26490 !       chip2=0.0
26491 !       chip12=0.0
26492 !c! not used by momo potential, but needed by sc_angular which is shared
26493 !c! by all energy_potential subroutines
26494        alf1   = 0.0d0
26495        alf2   = 0.0d0
26496        alf12  = 0.0d0
26497 !c! location, location, location
26498 !       xj  = c( 1, nres+j ) - xi
26499 !       yj  = c( 2, nres+j ) - yi
26500 !       zj  = c( 3, nres+j ) - zi
26501        dxj = dc_norm( 1, nres+j )
26502        dyj = dc_norm( 2, nres+j )
26503        dzj = dc_norm( 3, nres+j )
26504 !c! distance from center of chain(?) to polar/charged head
26505 !c!       write (*,*) "istate = ", 1
26506 !c!       write (*,*) "ii = ", 1
26507 !c!       write (*,*) "jj = ", 1
26508        d1 = dhead(1, 1, itypi, itypj)
26509        d2 = dhead(2, 1, itypi, itypj)
26510 !c! ai*aj from Fgb
26511        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26512 !c!       a12sq = a12sq * a12sq
26513 !c! charge of amino acid itypi is...
26514        Qi  = icharge(itypi)
26515        Qj  = icharge(itypj)
26516        Qij = Qi * Qj
26517 !c! chis1,2,12
26518        chis1 = chis(itypi,itypj)
26519        chis2 = chis(itypj,itypi)
26520        chis12 = chis1 * chis2
26521        sig1 = sigmap1(itypi,itypj)
26522        sig2 = sigmap2(itypi,itypj)
26523 !c!       write (*,*) "sig1 = ", sig1
26524 !c!       write (*,*) "sig2 = ", sig2
26525 !c! alpha factors from Fcav/Gcav
26526        b1cav = alphasur(1,itypi,itypj)
26527 !       b1cav=0.0
26528        b2cav = alphasur(2,itypi,itypj)
26529        b3cav = alphasur(3,itypi,itypj)
26530        b4cav = alphasur(4,itypi,itypj)
26531        wqd = wquad(itypi, itypj)
26532 !c! used by Fgb
26533        eps_in = epsintab(itypi,itypj)
26534        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26535 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
26536 !c!-------------------------------------------------------------------
26537 !c! tail location and distance calculations
26538        Rtail = 0.0d0
26539        DO k = 1, 3
26540         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26541         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26542        END DO
26543 !c! tail distances will be themselves usefull elswhere
26544 !c1 (in Gcav, for example)
26545        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26546        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26547        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26548        Rtail = dsqrt(  &
26549           (Rtail_distance(1)*Rtail_distance(1))  &
26550         + (Rtail_distance(2)*Rtail_distance(2))  &
26551         + (Rtail_distance(3)*Rtail_distance(3)))
26552 !c!-------------------------------------------------------------------
26553 !c! Calculate location and distance between polar heads
26554 !c! distance between heads
26555 !c! for each one of our three dimensional space...
26556        d1 = dhead(1, 1, itypi, itypj)
26557        d2 = dhead(2, 1, itypi, itypj)
26558
26559        DO k = 1,3
26560 !c! location of polar head is computed by taking hydrophobic centre
26561 !c! and moving by a d1 * dc_norm vector
26562 !c! see unres publications for very informative images
26563         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26564         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26565 !c! distance
26566 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26567 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26568         Rhead_distance(k) = chead(k,2) - chead(k,1)
26569        END DO
26570 !c! pitagoras (root of sum of squares)
26571        Rhead = dsqrt(   &
26572           (Rhead_distance(1)*Rhead_distance(1)) &
26573         + (Rhead_distance(2)*Rhead_distance(2)) &
26574         + (Rhead_distance(3)*Rhead_distance(3)))
26575 !c!-------------------------------------------------------------------
26576 !c! zero everything that should be zero'ed
26577        Egb = 0.0d0
26578        ECL = 0.0d0
26579        Elj = 0.0d0
26580        Equad = 0.0d0
26581        Epol = 0.0d0
26582        eheadtail = 0.0d0
26583        dGCLdOM1 = 0.0d0
26584        dGCLdOM2 = 0.0d0
26585        dGCLdOM12 = 0.0d0
26586        dPOLdOM1 = 0.0d0
26587        dPOLdOM2 = 0.0d0
26588        RETURN
26589       END SUBROUTINE elgrad_init
26590
26591       double precision function tschebyshev(m,n,x,y)
26592       implicit none
26593       integer i,m,n
26594       double precision x(n),y,yy(0:maxvar),aux
26595 !c Tschebyshev polynomial. Note that the first term is omitted
26596 !c m=0: the constant term is included
26597 !c m=1: the constant term is not included
26598       yy(0)=1.0d0
26599       yy(1)=y
26600       do i=2,n
26601         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
26602       enddo
26603       aux=0.0d0
26604       do i=m,n
26605         aux=aux+x(i)*yy(i)
26606       enddo
26607       tschebyshev=aux
26608       return
26609       end function tschebyshev
26610 !C--------------------------------------------------------------------------
26611       double precision function gradtschebyshev(m,n,x,y)
26612       implicit none
26613       integer i,m,n
26614       double precision x(n+1),y,yy(0:maxvar),aux
26615 !c Tschebyshev polynomial. Note that the first term is omitted
26616 !c m=0: the constant term is included
26617 !c m=1: the constant term is not included
26618       yy(0)=1.0d0
26619       yy(1)=2.0d0*y
26620       do i=2,n
26621         yy(i)=2*y*yy(i-1)-yy(i-2)
26622       enddo
26623       aux=0.0d0
26624       do i=m,n
26625         aux=aux+x(i+1)*yy(i)*(i+1)
26626 !C        print *, x(i+1),yy(i),i
26627       enddo
26628       gradtschebyshev=aux
26629       return
26630       end function gradtschebyshev
26631
26632
26633
26634
26635
26636       end module energy