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 !            write(iout,*),"just befor eelec call"
 614             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 615 !         write (iout,*) "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       if (nfgtasks.gt.1) then
 835       if (fg_rank.eq.0) then
 836       call ecatcat(ecationcation)
 837       endif
 838       else
 839       call ecatcat(ecationcation)
 840       endif
 841       call ecat_prot(ecation_prot)
 842       if (nres_molec(2).gt.0) then
 843       call eprot_sc_base(escbase)
 844       call epep_sc_base(epepbase)
 845       call eprot_sc_phosphate(escpho)
 846       call eprot_pep_phosphate(epeppho)
 847       else
 848       epepbase=0.0
 849       escbase=0.0
 850       escpho=0.0
 851       epeppho=0.0
 852       endif
 853 !      call ecatcat(ecationcation)
 854 !      print *,"after ebend", ebe_nucl
 855 #ifdef TIMING
 856       time_enecalc=time_enecalc+MPI_Wtime()-time00
 857 #endif
 858 !      print *,"Processor",myrank," computed Uconstr"
 859 #ifdef TIMING
 860       time00=MPI_Wtime()
 861 #endif
 862 !
 863 ! Sum the energies
 864 !
 865       energia(1)=evdw
 866 #ifdef SCP14
 867       energia(2)=evdw2-evdw2_14
 868       energia(18)=evdw2_14
 869 #else
 870       energia(2)=evdw2
 871       energia(18)=0.0d0
 872 #endif
 873 #ifdef SPLITELE
 874       energia(3)=ees
 875       energia(16)=evdw1
 876 #else
 877       energia(3)=ees+evdw1
 878       energia(16)=0.0d0
 879 #endif
 880       energia(4)=ecorr
 881       energia(5)=ecorr5
 882       energia(6)=ecorr6
 883       energia(7)=eel_loc
 884       energia(8)=eello_turn3
 885       energia(9)=eello_turn4
 886       energia(10)=eturn6
 887       energia(11)=ebe
 888       energia(12)=escloc
 889       energia(13)=etors
 890       energia(14)=etors_d
 891       energia(15)=ehpb
 892       energia(19)=edihcnstr
 893       energia(17)=estr
 894       energia(20)=Uconst+Uconst_back
 895       energia(21)=esccor
 896       energia(22)=eliptran
 897       energia(23)=Eafmforce
 898       energia(24)=ethetacnstr
 899       energia(25)=etube
 900 !---------------------------------------------------------------
 901       energia(26)=evdwpp
 902       energia(27)=eespp
 903       energia(28)=evdwpsb
 904       energia(29)=eelpsb
 905       energia(30)=evdwsb
 906       energia(31)=eelsb
 907       energia(32)=estr_nucl
 908       energia(33)=ebe_nucl
 909       energia(34)=esbloc
 910       energia(35)=etors_nucl
 911       energia(36)=etors_d_nucl
 912       energia(37)=ecorr_nucl
 913       energia(38)=ecorr3_nucl
 914 !----------------------------------------------------------------------
 915 !    Here are the energies showed per procesor if the are more processors
 916 !    per molecule then we sum it up in sum_energy subroutine
 917 !      print *," Processor",myrank," calls SUM_ENERGY"
 918       energia(41)=ecation_prot
 919       energia(42)=ecationcation
 920       energia(46)=escbase
 921       energia(47)=epepbase
 922       energia(48)=escpho
 923       energia(49)=epeppho
 924       call sum_energy(energia,.true.)
 925       if (dyn_ss) call dyn_set_nss
 926 !      print *," Processor",myrank," left SUM_ENERGY"
 927 #ifdef TIMING
 928       time_sumene=time_sumene+MPI_Wtime()-time00
 929 #endif
 930 !        call enerprint(energia)
 931 !elwrite(iout,*)"finish etotal"
 932       return
 933       end subroutine etotal
 934 !-----------------------------------------------------------------------------
 935       subroutine sum_energy(energia,reduce)
 936 !      implicit real*8 (a-h,o-z)
 937 !      include 'DIMENSIONS'
 938 #ifndef ISNAN
 939       external proc_proc
 940 #ifdef WINPGI
 941 !MS$ATTRIBUTES C ::  proc_proc
 942 #endif
 943 #endif
 944 #ifdef MPI
 945       include "mpif.h"
 946 #endif
 947 !      include 'COMMON.SETUP'
 948 !      include 'COMMON.IOUNITS'
 949       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 950 !      include 'COMMON.FFIELD'
 951 !      include 'COMMON.DERIV'
 952 !      include 'COMMON.INTERACT'
 953 !      include 'COMMON.SBRIDGE'
 954 !      include 'COMMON.CHAIN'
 955 !      include 'COMMON.VAR'
 956 !      include 'COMMON.CONTROL'
 957 !      include 'COMMON.TIME1'
 958       logical :: reduce
 959       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 960       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 961       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 962         eliptran,etube, Eafmforce,ethetacnstr
 963       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 964                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 965                       ecorr3_nucl
 966       real(kind=8) :: ecation_prot,ecationcation
 967       real(kind=8) :: escbase,epepbase,escpho,epeppho
 968       integer :: i
 969 #ifdef MPI
 970       integer :: ierr
 971       real(kind=8) :: time00
 972       if (nfgtasks.gt.1 .and. reduce) then
 973
 974 #ifdef DEBUG
 975         write (iout,*) "energies before REDUCE"
 976         call enerprint(energia)
 977         call flush(iout)
 978 #endif
 979         do i=0,n_ene
 980           enebuff(i)=energia(i)
 981         enddo
 982         time00=MPI_Wtime()
 983         call MPI_Barrier(FG_COMM,IERR)
 984         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 985         time00=MPI_Wtime()
 986         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 987           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 988 #ifdef DEBUG
 989         write (iout,*) "energies after REDUCE"
 990         call enerprint(energia)
 991         call flush(iout)
 992 #endif
 993         time_Reduce=time_Reduce+MPI_Wtime()-time00
 994       endif
 995       if (fg_rank.eq.0) then
 996 #endif
 997       evdw=energia(1)
 998 #ifdef SCP14
 999       evdw2=energia(2)+energia(18)
1000       evdw2_14=energia(18)
1001 #else
1002       evdw2=energia(2)
1003 #endif
1004 #ifdef SPLITELE
1005       ees=energia(3)
1006       evdw1=energia(16)
1007 #else
1008       ees=energia(3)
1009       evdw1=0.0d0
1010 #endif
1011       ecorr=energia(4)
1012       ecorr5=energia(5)
1013       ecorr6=energia(6)
1014       eel_loc=energia(7)
1015       eello_turn3=energia(8)
1016       eello_turn4=energia(9)
1017       eturn6=energia(10)
1018       ebe=energia(11)
1019       escloc=energia(12)
1020       etors=energia(13)
1021       etors_d=energia(14)
1022       ehpb=energia(15)
1023       edihcnstr=energia(19)
1024       estr=energia(17)
1025       Uconst=energia(20)
1026       esccor=energia(21)
1027       eliptran=energia(22)
1028       Eafmforce=energia(23)
1029       ethetacnstr=energia(24)
1030       etube=energia(25)
1031       evdwpp=energia(26)
1032       eespp=energia(27)
1033       evdwpsb=energia(28)
1034       eelpsb=energia(29)
1035       evdwsb=energia(30)
1036       eelsb=energia(31)
1037       estr_nucl=energia(32)
1038       ebe_nucl=energia(33)
1039       esbloc=energia(34)
1040       etors_nucl=energia(35)
1041       etors_d_nucl=energia(36)
1042       ecorr_nucl=energia(37)
1043       ecorr3_nucl=energia(38)
1044       ecation_prot=energia(41)
1045       ecationcation=energia(42)
1046       escbase=energia(46)
1047       epepbase=energia(47)
1048       escpho=energia(48)
1049       epeppho=energia(49)
1050 !      energia(41)=ecation_prot
1051 !      energia(42)=ecationcation
1052
1053
1054 #ifdef SPLITELE
1055       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1056        +wang*ebe+wtor*etors+wscloc*escloc &
1057        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1058        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1059        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1060        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1061        +Eafmforce+ethetacnstr  &
1062        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1063        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1064        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1065        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1066        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1067        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1068 #else
1069       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1070        +wang*ebe+wtor*etors+wscloc*escloc &
1071        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1072        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1073        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1074        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1075        +Eafmforce+ethetacnstr &
1076        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1077        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1078        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1079        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1080        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1081        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1082 #endif
1083       energia(0)=etot
1084 ! detecting NaNQ
1085 #ifdef ISNAN
1086 #ifdef AIX
1087       if (isnan(etot).ne.0) energia(0)=1.0d+99
1088 #else
1089       if (isnan(etot)) energia(0)=1.0d+99
1090 #endif
1091 #else
1092       i=0
1093 #ifdef WINPGI
1094       idumm=proc_proc(etot,i)
1095 #else
1096       call proc_proc(etot,i)
1097 #endif
1098       if(i.eq.1)energia(0)=1.0d+99
1099 #endif
1100 #ifdef MPI
1101       endif
1102 #endif
1103 !      call enerprint(energia)
1104       call flush(iout)
1105       return
1106       end subroutine sum_energy
1107 !-----------------------------------------------------------------------------
1108       subroutine rescale_weights(t_bath)
1109 !      implicit real*8 (a-h,o-z)
1110 #ifdef MPI
1111       include 'mpif.h'
1112 #endif
1113 !      include 'DIMENSIONS'
1114 !      include 'COMMON.IOUNITS'
1115 !      include 'COMMON.FFIELD'
1116 !      include 'COMMON.SBRIDGE'
1117       real(kind=8) :: kfac=2.4d0
1118       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1119 !el local variables
1120       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1121       real(kind=8) :: T0=3.0d2
1122       integer :: ierror
1123 !      facT=temp0/t_bath
1124 !      facT=2*temp0/(t_bath+temp0)
1125       if (rescale_mode.eq.0) then
1126         facT(1)=1.0d0
1127         facT(2)=1.0d0
1128         facT(3)=1.0d0
1129         facT(4)=1.0d0
1130         facT(5)=1.0d0
1131         facT(6)=1.0d0
1132       else if (rescale_mode.eq.1) then
1133         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1134         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1135         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1136         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1137         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1138 #ifdef WHAM_RUN
1139 !#if defined(WHAM_RUN) || defined(CLUSTER)
1140 #if defined(FUNCTH)
1141 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1142         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1143 #elif defined(FUNCT)
1144         facT(6)=t_bath/T0
1145 #else
1146         facT(6)=1.0d0
1147 #endif
1148 #endif
1149       else if (rescale_mode.eq.2) then
1150         x=t_bath/temp0
1151         x2=x*x
1152         x3=x2*x
1153         x4=x3*x
1154         x5=x4*x
1155         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1156         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1157         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1158         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1159         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1160 #ifdef WHAM_RUN
1161 !#if defined(WHAM_RUN) || defined(CLUSTER)
1162 #if defined(FUNCTH)
1163         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1164 #elif defined(FUNCT)
1165         facT(6)=t_bath/T0
1166 #else
1167         facT(6)=1.0d0
1168 #endif
1169 #endif
1170       else
1171         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1172         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1173 #ifdef MPI
1174        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1175 #endif
1176        stop 555
1177       endif
1178       welec=weights(3)*fact(1)
1179       wcorr=weights(4)*fact(3)
1180       wcorr5=weights(5)*fact(4)
1181       wcorr6=weights(6)*fact(5)
1182       wel_loc=weights(7)*fact(2)
1183       wturn3=weights(8)*fact(2)
1184       wturn4=weights(9)*fact(3)
1185       wturn6=weights(10)*fact(5)
1186       wtor=weights(13)*fact(1)
1187       wtor_d=weights(14)*fact(2)
1188       wsccor=weights(21)*fact(1)
1189
1190       return
1191       end subroutine rescale_weights
1192 !-----------------------------------------------------------------------------
1193       subroutine enerprint(energia)
1194 !      implicit real*8 (a-h,o-z)
1195 !      include 'DIMENSIONS'
1196 !      include 'COMMON.IOUNITS'
1197 !      include 'COMMON.FFIELD'
1198 !      include 'COMMON.SBRIDGE'
1199 !      include 'COMMON.MD'
1200       real(kind=8) :: energia(0:n_ene)
1201 !el local variables
1202       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1203       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1204       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1205        etube,ethetacnstr,Eafmforce
1206       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1207                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1208                       ecorr3_nucl
1209       real(kind=8) :: ecation_prot,ecationcation
1210       real(kind=8) :: escbase,epepbase,escpho,epeppho
1211
1212       etot=energia(0)
1213       evdw=energia(1)
1214       evdw2=energia(2)
1215 #ifdef SCP14
1216       evdw2=energia(2)+energia(18)
1217 #else
1218       evdw2=energia(2)
1219 #endif
1220       ees=energia(3)
1221 #ifdef SPLITELE
1222       evdw1=energia(16)
1223 #endif
1224       ecorr=energia(4)
1225       ecorr5=energia(5)
1226       ecorr6=energia(6)
1227       eel_loc=energia(7)
1228       eello_turn3=energia(8)
1229       eello_turn4=energia(9)
1230       eello_turn6=energia(10)
1231       ebe=energia(11)
1232       escloc=energia(12)
1233       etors=energia(13)
1234       etors_d=energia(14)
1235       ehpb=energia(15)
1236       edihcnstr=energia(19)
1237       estr=energia(17)
1238       Uconst=energia(20)
1239       esccor=energia(21)
1240       eliptran=energia(22)
1241       Eafmforce=energia(23)
1242       ethetacnstr=energia(24)
1243       etube=energia(25)
1244       evdwpp=energia(26)
1245       eespp=energia(27)
1246       evdwpsb=energia(28)
1247       eelpsb=energia(29)
1248       evdwsb=energia(30)
1249       eelsb=energia(31)
1250       estr_nucl=energia(32)
1251       ebe_nucl=energia(33)
1252       esbloc=energia(34)
1253       etors_nucl=energia(35)
1254       etors_d_nucl=energia(36)
1255       ecorr_nucl=energia(37)
1256       ecorr3_nucl=energia(38)
1257       ecation_prot=energia(41)
1258       ecationcation=energia(42)
1259       escbase=energia(46)
1260       epepbase=energia(47)
1261       escpho=energia(48)
1262       epeppho=energia(49)
1263 #ifdef SPLITELE
1264       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1265         estr,wbond,ebe,wang,&
1266         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1267         ecorr,wcorr,&
1268         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1269         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1270         edihcnstr,ethetacnstr,ebr*nss,&
1271         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1272         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1273         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1274         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1275         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1276         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1277         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1278         etot
1279    10 format (/'Virtual-chain energies:'// &
1280        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1281        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1282        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1283        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1284        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1285        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1286        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1287        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1288        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1289        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1290        ' (SS bridges & dist. cnstr.)'/ &
1291        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1292        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1293        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1294        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1295        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1296        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1297        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1298        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1299        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1300        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1301        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1302        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1303        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1304        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1305        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1306        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1307        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1308        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1309        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1310        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1311        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1312        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1313        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1314        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1315        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1316        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1317        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1318        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1319        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1320        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1321        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1322        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1323        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1324        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1325        'ETOT=  ',1pE16.6,' (total)')
1326 #else
1327       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1328         estr,wbond,ebe,wang,&
1329         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1330         ecorr,wcorr,&
1331         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1332         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1333         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1334         etube,wtube, &
1335         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1336         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1337         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1338         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1339         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1340         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1341         etot
1342    10 format (/'Virtual-chain energies:'// &
1343        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1344        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1345        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1346        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1347        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1348        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1349        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1350        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1351        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1352        ' (SS bridges & dist. cnstr.)'/ &
1353        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1354        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1355        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1356        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1357        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1358        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1359        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1360        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1361        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1362        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1363        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1364        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1365        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1366        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1367        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1368        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1369        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1370        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1371        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1372        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1373        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1374        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1375        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1376        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1377        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1378        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1379        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1380        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1381        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1382        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1383        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1384        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1385        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1386        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1387        'ETOT=  ',1pE16.6,' (total)')
1388 #endif
1389       return
1390       end subroutine enerprint
1391 !-----------------------------------------------------------------------------
1392       subroutine elj(evdw)
1393 !
1394 ! This subroutine calculates the interaction energy of nonbonded side chains
1395 ! assuming the LJ potential of interaction.
1396 !
1397 !      implicit real*8 (a-h,o-z)
1398 !      include 'DIMENSIONS'
1399       real(kind=8),parameter :: accur=1.0d-10
1400 !      include 'COMMON.GEO'
1401 !      include 'COMMON.VAR'
1402 !      include 'COMMON.LOCAL'
1403 !      include 'COMMON.CHAIN'
1404 !      include 'COMMON.DERIV'
1405 !      include 'COMMON.INTERACT'
1406 !      include 'COMMON.TORSION'
1407 !      include 'COMMON.SBRIDGE'
1408 !      include 'COMMON.NAMES'
1409 !      include 'COMMON.IOUNITS'
1410 !      include 'COMMON.CONTACTS'
1411       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1412       integer :: num_conti
1413 !el local variables
1414       integer :: i,itypi,iint,j,itypi1,itypj,k
1415       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1416       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1417       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1418
1419 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1420       evdw=0.0D0
1421 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1422 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1423 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1424 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1425
1426       do i=iatsc_s,iatsc_e
1427         itypi=iabs(itype(i,1))
1428         if (itypi.eq.ntyp1) cycle
1429         itypi1=iabs(itype(i+1,1))
1430         xi=c(1,nres+i)
1431         yi=c(2,nres+i)
1432         zi=c(3,nres+i)
1433 ! Change 12/1/95
1434         num_conti=0
1435 !
1436 ! Calculate SC interaction energy.
1437 !
1438         do iint=1,nint_gr(i)
1439 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1440 !d   &                  'iend=',iend(i,iint)
1441           do j=istart(i,iint),iend(i,iint)
1442             itypj=iabs(itype(j,1))
1443             if (itypj.eq.ntyp1) cycle
1444             xj=c(1,nres+j)-xi
1445             yj=c(2,nres+j)-yi
1446             zj=c(3,nres+j)-zi
1447 ! Change 12/1/95 to calculate four-body interactions
1448             rij=xj*xj+yj*yj+zj*zj
1449             rrij=1.0D0/rij
1450 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1451             eps0ij=eps(itypi,itypj)
1452             fac=rrij**expon2
1453             e1=fac*fac*aa_aq(itypi,itypj)
1454             e2=fac*bb_aq(itypi,itypj)
1455             evdwij=e1+e2
1456 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1457 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1458 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1459 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1460 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1461 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1462             evdw=evdw+evdwij
1463 !
1464 ! Calculate the components of the gradient in DC and X
1465 !
1466             fac=-rrij*(e1+evdwij)
1467             gg(1)=xj*fac
1468             gg(2)=yj*fac
1469             gg(3)=zj*fac
1470             do k=1,3
1471               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1475             enddo
1476 !grad            do k=i,j-1
1477 !grad              do l=1,3
1478 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1479 !grad              enddo
1480 !grad            enddo
1481 !
1482 ! 12/1/95, revised on 5/20/97
1483 !
1484 ! Calculate the contact function. The ith column of the array JCONT will
1485 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1486 ! greater than I). The arrays FACONT and GACONT will contain the values of
1487 ! the contact function and its derivative.
1488 !
1489 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1490 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1491 ! Uncomment next line, if the correlation interactions are contact function only
1492             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1493               rij=dsqrt(rij)
1494               sigij=sigma(itypi,itypj)
1495               r0ij=rs0(itypi,itypj)
1496 !
1497 ! Check whether the SC's are not too far to make a contact.
1498 !
1499               rcut=1.5d0*r0ij
1500               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1501 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1502 !
1503               if (fcont.gt.0.0D0) then
1504 ! If the SC-SC distance if close to sigma, apply spline.
1505 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1506 !Adam &             fcont1,fprimcont1)
1507 !Adam           fcont1=1.0d0-fcont1
1508 !Adam           if (fcont1.gt.0.0d0) then
1509 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1510 !Adam             fcont=fcont*fcont1
1511 !Adam           endif
1512 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1513 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1514 !ga             do k=1,3
1515 !ga               gg(k)=gg(k)*eps0ij
1516 !ga             enddo
1517 !ga             eps0ij=-evdwij*eps0ij
1518 ! Uncomment for AL's type of SC correlation interactions.
1519 !adam           eps0ij=-evdwij
1520                 num_conti=num_conti+1
1521                 jcont(num_conti,i)=j
1522                 facont(num_conti,i)=fcont*eps0ij
1523                 fprimcont=eps0ij*fprimcont/rij
1524                 fcont=expon*fcont
1525 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1526 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1527 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1528 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1529                 gacont(1,num_conti,i)=-fprimcont*xj
1530                 gacont(2,num_conti,i)=-fprimcont*yj
1531                 gacont(3,num_conti,i)=-fprimcont*zj
1532 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1533 !d              write (iout,'(2i3,3f10.5)')
1534 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1535               endif
1536             endif
1537           enddo      ! j
1538         enddo        ! iint
1539 ! Change 12/1/95
1540         num_cont(i)=num_conti
1541       enddo          ! i
1542       do i=1,nct
1543         do j=1,3
1544           gvdwc(j,i)=expon*gvdwc(j,i)
1545           gvdwx(j,i)=expon*gvdwx(j,i)
1546         enddo
1547       enddo
1548 !******************************************************************************
1549 !
1550 !                              N O T E !!!
1551 !
1552 ! To save time, the factor of EXPON has been extracted from ALL components
1553 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1554 ! use!
1555 !
1556 !******************************************************************************
1557       return
1558       end subroutine elj
1559 !-----------------------------------------------------------------------------
1560       subroutine eljk(evdw)
1561 !
1562 ! This subroutine calculates the interaction energy of nonbonded side chains
1563 ! assuming the LJK potential of interaction.
1564 !
1565 !      implicit real*8 (a-h,o-z)
1566 !      include 'DIMENSIONS'
1567 !      include 'COMMON.GEO'
1568 !      include 'COMMON.VAR'
1569 !      include 'COMMON.LOCAL'
1570 !      include 'COMMON.CHAIN'
1571 !      include 'COMMON.DERIV'
1572 !      include 'COMMON.INTERACT'
1573 !      include 'COMMON.IOUNITS'
1574 !      include 'COMMON.NAMES'
1575       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1576       logical :: scheck
1577 !el local variables
1578       integer :: i,iint,j,itypi,itypi1,k,itypj
1579       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1580       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1581
1582 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1583       evdw=0.0D0
1584       do i=iatsc_s,iatsc_e
1585         itypi=iabs(itype(i,1))
1586         if (itypi.eq.ntyp1) cycle
1587         itypi1=iabs(itype(i+1,1))
1588         xi=c(1,nres+i)
1589         yi=c(2,nres+i)
1590         zi=c(3,nres+i)
1591 !
1592 ! Calculate SC interaction energy.
1593 !
1594         do iint=1,nint_gr(i)
1595           do j=istart(i,iint),iend(i,iint)
1596             itypj=iabs(itype(j,1))
1597             if (itypj.eq.ntyp1) cycle
1598             xj=c(1,nres+j)-xi
1599             yj=c(2,nres+j)-yi
1600             zj=c(3,nres+j)-zi
1601             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1602             fac_augm=rrij**expon
1603             e_augm=augm(itypi,itypj)*fac_augm
1604             r_inv_ij=dsqrt(rrij)
1605             rij=1.0D0/r_inv_ij
1606             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1607             fac=r_shift_inv**expon
1608             e1=fac*fac*aa_aq(itypi,itypj)
1609             e2=fac*bb_aq(itypi,itypj)
1610             evdwij=e_augm+e1+e2
1611 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1612 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1613 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1614 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1615 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1616 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1617 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1618             evdw=evdw+evdwij
1619 !
1620 ! Calculate the components of the gradient in DC and X
1621 !
1622             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1623             gg(1)=xj*fac
1624             gg(2)=yj*fac
1625             gg(3)=zj*fac
1626             do k=1,3
1627               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1628               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1629               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1630               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1631             enddo
1632 !grad            do k=i,j-1
1633 !grad              do l=1,3
1634 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1635 !grad              enddo
1636 !grad            enddo
1637           enddo      ! j
1638         enddo        ! iint
1639       enddo          ! i
1640       do i=1,nct
1641         do j=1,3
1642           gvdwc(j,i)=expon*gvdwc(j,i)
1643           gvdwx(j,i)=expon*gvdwx(j,i)
1644         enddo
1645       enddo
1646       return
1647       end subroutine eljk
1648 !-----------------------------------------------------------------------------
1649       subroutine ebp(evdw)
1650 !
1651 ! This subroutine calculates the interaction energy of nonbonded side chains
1652 ! assuming the Berne-Pechukas potential of interaction.
1653 !
1654       use comm_srutu
1655       use calc_data
1656 !      implicit real*8 (a-h,o-z)
1657 !      include 'DIMENSIONS'
1658 !      include 'COMMON.GEO'
1659 !      include 'COMMON.VAR'
1660 !      include 'COMMON.LOCAL'
1661 !      include 'COMMON.CHAIN'
1662 !      include 'COMMON.DERIV'
1663 !      include 'COMMON.NAMES'
1664 !      include 'COMMON.INTERACT'
1665 !      include 'COMMON.IOUNITS'
1666 !      include 'COMMON.CALC'
1667       use comm_srutu
1668 !el      integer :: icall
1669 !el      common /srutu/ icall
1670 !     double precision rrsave(maxdim)
1671       logical :: lprn
1672 !el local variables
1673       integer :: iint,itypi,itypi1,itypj
1674       real(kind=8) :: rrij,xi,yi,zi
1675       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1676
1677 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1678       evdw=0.0D0
1679 !     if (icall.eq.0) then
1680 !       lprn=.true.
1681 !     else
1682         lprn=.false.
1683 !     endif
1684 !el      ind=0
1685       do i=iatsc_s,iatsc_e
1686         itypi=iabs(itype(i,1))
1687         if (itypi.eq.ntyp1) cycle
1688         itypi1=iabs(itype(i+1,1))
1689         xi=c(1,nres+i)
1690         yi=c(2,nres+i)
1691         zi=c(3,nres+i)
1692         dxi=dc_norm(1,nres+i)
1693         dyi=dc_norm(2,nres+i)
1694         dzi=dc_norm(3,nres+i)
1695 !        dsci_inv=dsc_inv(itypi)
1696         dsci_inv=vbld_inv(i+nres)
1697 !
1698 ! Calculate SC interaction energy.
1699 !
1700         do iint=1,nint_gr(i)
1701           do j=istart(i,iint),iend(i,iint)
1702 !el            ind=ind+1
1703             itypj=iabs(itype(j,1))
1704             if (itypj.eq.ntyp1) cycle
1705 !            dscj_inv=dsc_inv(itypj)
1706             dscj_inv=vbld_inv(j+nres)
1707             chi1=chi(itypi,itypj)
1708             chi2=chi(itypj,itypi)
1709             chi12=chi1*chi2
1710             chip1=chip(itypi)
1711             chip2=chip(itypj)
1712             chip12=chip1*chip2
1713             alf1=alp(itypi)
1714             alf2=alp(itypj)
1715             alf12=0.5D0*(alf1+alf2)
1716 ! For diagnostics only!!!
1717 !           chi1=0.0D0
1718 !           chi2=0.0D0
1719 !           chi12=0.0D0
1720 !           chip1=0.0D0
1721 !           chip2=0.0D0
1722 !           chip12=0.0D0
1723 !           alf1=0.0D0
1724 !           alf2=0.0D0
1725 !           alf12=0.0D0
1726             xj=c(1,nres+j)-xi
1727             yj=c(2,nres+j)-yi
1728             zj=c(3,nres+j)-zi
1729             dxj=dc_norm(1,nres+j)
1730             dyj=dc_norm(2,nres+j)
1731             dzj=dc_norm(3,nres+j)
1732             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1733 !d          if (icall.eq.0) then
1734 !d            rrsave(ind)=rrij
1735 !d          else
1736 !d            rrij=rrsave(ind)
1737 !d          endif
1738             rij=dsqrt(rrij)
1739 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1740             call sc_angular
1741 ! Calculate whole angle-dependent part of epsilon and contributions
1742 ! to its derivatives
1743             fac=(rrij*sigsq)**expon2
1744             e1=fac*fac*aa_aq(itypi,itypj)
1745             e2=fac*bb_aq(itypi,itypj)
1746             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1747             eps2der=evdwij*eps3rt
1748             eps3der=evdwij*eps2rt
1749             evdwij=evdwij*eps2rt*eps3rt
1750             evdw=evdw+evdwij
1751             if (lprn) then
1752             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1753             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1754 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1755 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1756 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1757 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1758 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1759 !d     &        evdwij
1760             endif
1761 ! Calculate gradient components.
1762             e1=e1*eps1*eps2rt**2*eps3rt**2
1763             fac=-expon*(e1+evdwij)
1764             sigder=fac/sigsq
1765             fac=rrij*fac
1766 ! Calculate radial part of the gradient
1767             gg(1)=xj*fac
1768             gg(2)=yj*fac
1769             gg(3)=zj*fac
1770 ! Calculate the angular part of the gradient and sum add the contributions
1771 ! to the appropriate components of the Cartesian gradient.
1772             call sc_grad
1773           enddo      ! j
1774         enddo        ! iint
1775       enddo          ! i
1776 !     stop
1777       return
1778       end subroutine ebp
1779 !-----------------------------------------------------------------------------
1780       subroutine egb(evdw)
1781 !
1782 ! This subroutine calculates the interaction energy of nonbonded side chains
1783 ! assuming the Gay-Berne potential of interaction.
1784 !
1785       use calc_data
1786 !      implicit real*8 (a-h,o-z)
1787 !      include 'DIMENSIONS'
1788 !      include 'COMMON.GEO'
1789 !      include 'COMMON.VAR'
1790 !      include 'COMMON.LOCAL'
1791 !      include 'COMMON.CHAIN'
1792 !      include 'COMMON.DERIV'
1793 !      include 'COMMON.NAMES'
1794 !      include 'COMMON.INTERACT'
1795 !      include 'COMMON.IOUNITS'
1796 !      include 'COMMON.CALC'
1797 !      include 'COMMON.CONTROL'
1798 !      include 'COMMON.SBRIDGE'
1799       logical :: lprn
1800 !el local variables
1801       integer :: iint,itypi,itypi1,itypj,subchap
1802       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1803       real(kind=8) :: evdw,sig0ij
1804       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1805                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1806                     sslipi,sslipj,faclip
1807       integer :: ii
1808       real(kind=8) :: fracinbuf
1809
1810 !cccc      energy_dec=.false.
1811 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1812       evdw=0.0D0
1813       lprn=.false.
1814 !     if (icall.eq.0) lprn=.false.
1815 !el      ind=0
1816       dCAVdOM2=0.0d0
1817       dGCLdOM2=0.0d0
1818       dPOLdOM2=0.0d0
1819       dCAVdOM1=0.0d0
1820       dGCLdOM1=0.0d0
1821       dPOLdOM1=0.0d0
1822
1823
1824       do i=iatsc_s,iatsc_e
1825 !C        print *,"I am in EVDW",i
1826         itypi=iabs(itype(i,1))
1827 !        if (i.ne.47) cycle
1828         if (itypi.eq.ntyp1) cycle
1829         itypi1=iabs(itype(i+1,1))
1830         xi=c(1,nres+i)
1831         yi=c(2,nres+i)
1832         zi=c(3,nres+i)
1833           xi=dmod(xi,boxxsize)
1834           if (xi.lt.0) xi=xi+boxxsize
1835           yi=dmod(yi,boxysize)
1836           if (yi.lt.0) yi=yi+boxysize
1837           zi=dmod(zi,boxzsize)
1838           if (zi.lt.0) zi=zi+boxzsize
1839
1840        if ((zi.gt.bordlipbot)  &
1841         .and.(zi.lt.bordliptop)) then
1842 !C the energy transfer exist
1843         if (zi.lt.buflipbot) then
1844 !C what fraction I am in
1845          fracinbuf=1.0d0-  &
1846               ((zi-bordlipbot)/lipbufthick)
1847 !C lipbufthick is thickenes of lipid buffore
1848          sslipi=sscalelip(fracinbuf)
1849          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1850         elseif (zi.gt.bufliptop) then
1851          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1852          sslipi=sscalelip(fracinbuf)
1853          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1854         else
1855          sslipi=1.0d0
1856          ssgradlipi=0.0
1857         endif
1858        else
1859          sslipi=0.0d0
1860          ssgradlipi=0.0
1861        endif
1862 !       print *, sslipi,ssgradlipi
1863         dxi=dc_norm(1,nres+i)
1864         dyi=dc_norm(2,nres+i)
1865         dzi=dc_norm(3,nres+i)
1866 !        dsci_inv=dsc_inv(itypi)
1867         dsci_inv=vbld_inv(i+nres)
1868 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1869 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1870 !
1871 ! Calculate SC interaction energy.
1872 !
1873         do iint=1,nint_gr(i)
1874           do j=istart(i,iint),iend(i,iint)
1875             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1876               call dyn_ssbond_ene(i,j,evdwij)
1877               evdw=evdw+evdwij
1878               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1879                               'evdw',i,j,evdwij,' ss'
1880 !              if (energy_dec) write (iout,*) &
1881 !                              'evdw',i,j,evdwij,' ss'
1882              do k=j+1,iend(i,iint)
1883 !C search over all next residues
1884               if (dyn_ss_mask(k)) then
1885 !C check if they are cysteins
1886 !C              write(iout,*) 'k=',k
1887
1888 !c              write(iout,*) "PRZED TRI", evdwij
1889 !               evdwij_przed_tri=evdwij
1890               call triple_ssbond_ene(i,j,k,evdwij)
1891 !c               if(evdwij_przed_tri.ne.evdwij) then
1892 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1893 !c               endif
1894
1895 !c              write(iout,*) "PO TRI", evdwij
1896 !C call the energy function that removes the artifical triple disulfide
1897 !C bond the soubroutine is located in ssMD.F
1898               evdw=evdw+evdwij
1899               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1900                             'evdw',i,j,evdwij,'tss'
1901               endif!dyn_ss_mask(k)
1902              enddo! k
1903             ELSE
1904 !el            ind=ind+1
1905             itypj=iabs(itype(j,1))
1906             if (itypj.eq.ntyp1) cycle
1907 !             if (j.ne.78) cycle
1908 !            dscj_inv=dsc_inv(itypj)
1909             dscj_inv=vbld_inv(j+nres)
1910 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1911 !              1.0d0/vbld(j+nres) !d
1912 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1913             sig0ij=sigma(itypi,itypj)
1914             chi1=chi(itypi,itypj)
1915             chi2=chi(itypj,itypi)
1916             chi12=chi1*chi2
1917             chip1=chip(itypi)
1918             chip2=chip(itypj)
1919             chip12=chip1*chip2
1920             alf1=alp(itypi)
1921             alf2=alp(itypj)
1922             alf12=0.5D0*(alf1+alf2)
1923 ! For diagnostics only!!!
1924 !           chi1=0.0D0
1925 !           chi2=0.0D0
1926 !           chi12=0.0D0
1927 !           chip1=0.0D0
1928 !           chip2=0.0D0
1929 !           chip12=0.0D0
1930 !           alf1=0.0D0
1931 !           alf2=0.0D0
1932 !           alf12=0.0D0
1933            xj=c(1,nres+j)
1934            yj=c(2,nres+j)
1935            zj=c(3,nres+j)
1936           xj=dmod(xj,boxxsize)
1937           if (xj.lt.0) xj=xj+boxxsize
1938           yj=dmod(yj,boxysize)
1939           if (yj.lt.0) yj=yj+boxysize
1940           zj=dmod(zj,boxzsize)
1941           if (zj.lt.0) zj=zj+boxzsize
1942 !          print *,"tu",xi,yi,zi,xj,yj,zj
1943 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1944 ! this fragment set correct epsilon for lipid phase
1945        if ((zj.gt.bordlipbot)  &
1946        .and.(zj.lt.bordliptop)) then
1947 !C the energy transfer exist
1948         if (zj.lt.buflipbot) then
1949 !C what fraction I am in
1950          fracinbuf=1.0d0-     &
1951              ((zj-bordlipbot)/lipbufthick)
1952 !C lipbufthick is thickenes of lipid buffore
1953          sslipj=sscalelip(fracinbuf)
1954          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1955         elseif (zj.gt.bufliptop) then
1956          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1957          sslipj=sscalelip(fracinbuf)
1958          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1959         else
1960          sslipj=1.0d0
1961          ssgradlipj=0.0
1962         endif
1963        else
1964          sslipj=0.0d0
1965          ssgradlipj=0.0
1966        endif
1967       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1968        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1969       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1970        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1971 !------------------------------------------------
1972       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1973       xj_safe=xj
1974       yj_safe=yj
1975       zj_safe=zj
1976       subchap=0
1977       do xshift=-1,1
1978       do yshift=-1,1
1979       do zshift=-1,1
1980           xj=xj_safe+xshift*boxxsize
1981           yj=yj_safe+yshift*boxysize
1982           zj=zj_safe+zshift*boxzsize
1983           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1984           if(dist_temp.lt.dist_init) then
1985             dist_init=dist_temp
1986             xj_temp=xj
1987             yj_temp=yj
1988             zj_temp=zj
1989             subchap=1
1990           endif
1991        enddo
1992        enddo
1993        enddo
1994        if (subchap.eq.1) then
1995           xj=xj_temp-xi
1996           yj=yj_temp-yi
1997           zj=zj_temp-zi
1998        else
1999           xj=xj_safe-xi
2000           yj=yj_safe-yi
2001           zj=zj_safe-zi
2002        endif
2003             dxj=dc_norm(1,nres+j)
2004             dyj=dc_norm(2,nres+j)
2005             dzj=dc_norm(3,nres+j)
2006 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2007 !            write (iout,*) "j",j," dc_norm",& !d
2008 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2009 !          write(iout,*)"rrij ",rrij
2010 !          write(iout,*)"xj yj zj ", xj, yj, zj
2011 !          write(iout,*)"xi yi zi ", xi, yi, zi
2012 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2013             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2014             rij=dsqrt(rrij)
2015             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
2016             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
2017 !            print *,sss_ele_cut,sss_ele_grad,&
2018 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2019             if (sss_ele_cut.le.0.0) cycle
2020 ! Calculate angle-dependent terms of energy and contributions to their
2021 ! derivatives.
2022             call sc_angular
2023             sigsq=1.0D0/sigsq
2024             sig=sig0ij*dsqrt(sigsq)
2025             rij_shift=1.0D0/rij-sig+sig0ij
2026 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2027 !            "sig0ij",sig0ij
2028 ! for diagnostics; uncomment
2029 !            rij_shift=1.2*sig0ij
2030 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2031             if (rij_shift.le.0.0D0) then
2032               evdw=1.0D20
2033 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2034 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2035 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2036               return
2037             endif
2038             sigder=-sig*sigsq
2039 !---------------------------------------------------------------
2040             rij_shift=1.0D0/rij_shift
2041             fac=rij_shift**expon
2042             faclip=fac
2043             e1=fac*fac*aa!(itypi,itypj)
2044             e2=fac*bb!(itypi,itypj)
2045             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2046             eps2der=evdwij*eps3rt
2047             eps3der=evdwij*eps2rt
2048 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2049 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2050 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2051             evdwij=evdwij*eps2rt*eps3rt
2052             evdw=evdw+evdwij*sss_ele_cut
2053             if (lprn) then
2054             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2055             epsi=bb**2/aa!(itypi,itypj)
2056             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2057               restyp(itypi,1),i,restyp(itypj,1),j, &
2058               epsi,sigm,chi1,chi2,chip1,chip2, &
2059               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2060               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2061               evdwij
2062             endif
2063
2064             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2065                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2066 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2067 !            if (energy_dec) write (iout,*) &
2068 !                             'evdw',i,j,evdwij
2069 !                       print *,"ZALAMKA", evdw
2070
2071 ! Calculate gradient components.
2072             e1=e1*eps1*eps2rt**2*eps3rt**2
2073             fac=-expon*(e1+evdwij)*rij_shift
2074             sigder=fac*sigder
2075             fac=rij*fac
2076 !            print *,'before fac',fac,rij,evdwij
2077             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2078             /sigma(itypi,itypj)*rij
2079 !            print *,'grad part scale',fac,   &
2080 !             evdwij*sss_ele_grad/sss_ele_cut &
2081 !            /sigma(itypi,itypj)*rij
2082 !            fac=0.0d0
2083 ! Calculate the radial part of the gradient
2084             gg(1)=xj*fac
2085             gg(2)=yj*fac
2086             gg(3)=zj*fac
2087 !C Calculate the radial part of the gradient
2088             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2089        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2090         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2091        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2092             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2093             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2094
2095 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2096 ! Calculate angular part of the gradient.
2097             call sc_grad
2098             ENDIF    ! dyn_ss
2099           enddo      ! j
2100         enddo        ! iint
2101       enddo          ! i
2102 !       print *,"ZALAMKA", evdw
2103 !      write (iout,*) "Number of loop steps in EGB:",ind
2104 !ccc      energy_dec=.false.
2105       return
2106       end subroutine egb
2107 !-----------------------------------------------------------------------------
2108       subroutine egbv(evdw)
2109 !
2110 ! This subroutine calculates the interaction energy of nonbonded side chains
2111 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2112 !
2113       use comm_srutu
2114       use calc_data
2115 !      implicit real*8 (a-h,o-z)
2116 !      include 'DIMENSIONS'
2117 !      include 'COMMON.GEO'
2118 !      include 'COMMON.VAR'
2119 !      include 'COMMON.LOCAL'
2120 !      include 'COMMON.CHAIN'
2121 !      include 'COMMON.DERIV'
2122 !      include 'COMMON.NAMES'
2123 !      include 'COMMON.INTERACT'
2124 !      include 'COMMON.IOUNITS'
2125 !      include 'COMMON.CALC'
2126       use comm_srutu
2127 !el      integer :: icall
2128 !el      common /srutu/ icall
2129       logical :: lprn
2130 !el local variables
2131       integer :: iint,itypi,itypi1,itypj
2132       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2133       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2134
2135 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2136       evdw=0.0D0
2137       lprn=.false.
2138 !     if (icall.eq.0) lprn=.true.
2139 !el      ind=0
2140       do i=iatsc_s,iatsc_e
2141         itypi=iabs(itype(i,1))
2142         if (itypi.eq.ntyp1) cycle
2143         itypi1=iabs(itype(i+1,1))
2144         xi=c(1,nres+i)
2145         yi=c(2,nres+i)
2146         zi=c(3,nres+i)
2147         dxi=dc_norm(1,nres+i)
2148         dyi=dc_norm(2,nres+i)
2149         dzi=dc_norm(3,nres+i)
2150 !        dsci_inv=dsc_inv(itypi)
2151         dsci_inv=vbld_inv(i+nres)
2152 !
2153 ! Calculate SC interaction energy.
2154 !
2155         do iint=1,nint_gr(i)
2156           do j=istart(i,iint),iend(i,iint)
2157 !el            ind=ind+1
2158             itypj=iabs(itype(j,1))
2159             if (itypj.eq.ntyp1) cycle
2160 !            dscj_inv=dsc_inv(itypj)
2161             dscj_inv=vbld_inv(j+nres)
2162             sig0ij=sigma(itypi,itypj)
2163             r0ij=r0(itypi,itypj)
2164             chi1=chi(itypi,itypj)
2165             chi2=chi(itypj,itypi)
2166             chi12=chi1*chi2
2167             chip1=chip(itypi)
2168             chip2=chip(itypj)
2169             chip12=chip1*chip2
2170             alf1=alp(itypi)
2171             alf2=alp(itypj)
2172             alf12=0.5D0*(alf1+alf2)
2173 ! For diagnostics only!!!
2174 !           chi1=0.0D0
2175 !           chi2=0.0D0
2176 !           chi12=0.0D0
2177 !           chip1=0.0D0
2178 !           chip2=0.0D0
2179 !           chip12=0.0D0
2180 !           alf1=0.0D0
2181 !           alf2=0.0D0
2182 !           alf12=0.0D0
2183             xj=c(1,nres+j)-xi
2184             yj=c(2,nres+j)-yi
2185             zj=c(3,nres+j)-zi
2186             dxj=dc_norm(1,nres+j)
2187             dyj=dc_norm(2,nres+j)
2188             dzj=dc_norm(3,nres+j)
2189             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2190             rij=dsqrt(rrij)
2191 ! Calculate angle-dependent terms of energy and contributions to their
2192 ! derivatives.
2193             call sc_angular
2194             sigsq=1.0D0/sigsq
2195             sig=sig0ij*dsqrt(sigsq)
2196             rij_shift=1.0D0/rij-sig+r0ij
2197 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2198             if (rij_shift.le.0.0D0) then
2199               evdw=1.0D20
2200               return
2201             endif
2202             sigder=-sig*sigsq
2203 !---------------------------------------------------------------
2204             rij_shift=1.0D0/rij_shift
2205             fac=rij_shift**expon
2206             e1=fac*fac*aa_aq(itypi,itypj)
2207             e2=fac*bb_aq(itypi,itypj)
2208             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2209             eps2der=evdwij*eps3rt
2210             eps3der=evdwij*eps2rt
2211             fac_augm=rrij**expon
2212             e_augm=augm(itypi,itypj)*fac_augm
2213             evdwij=evdwij*eps2rt*eps3rt
2214             evdw=evdw+evdwij+e_augm
2215             if (lprn) then
2216             sigm=dabs(aa_aq(itypi,itypj)/&
2217             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2218             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2219             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2220               restyp(itypi,1),i,restyp(itypj,1),j,&
2221               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2222               chi1,chi2,chip1,chip2,&
2223               eps1,eps2rt**2,eps3rt**2,&
2224               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2225               evdwij+e_augm
2226             endif
2227 ! Calculate gradient components.
2228             e1=e1*eps1*eps2rt**2*eps3rt**2
2229             fac=-expon*(e1+evdwij)*rij_shift
2230             sigder=fac*sigder
2231             fac=rij*fac-2*expon*rrij*e_augm
2232 ! Calculate the radial part of the gradient
2233             gg(1)=xj*fac
2234             gg(2)=yj*fac
2235             gg(3)=zj*fac
2236 ! Calculate angular part of the gradient.
2237             call sc_grad
2238           enddo      ! j
2239         enddo        ! iint
2240       enddo          ! i
2241       end subroutine egbv
2242 !-----------------------------------------------------------------------------
2243 !el      subroutine sc_angular in module geometry
2244 !-----------------------------------------------------------------------------
2245       subroutine e_softsphere(evdw)
2246 !
2247 ! This subroutine calculates the interaction energy of nonbonded side chains
2248 ! assuming the LJ potential of interaction.
2249 !
2250 !      implicit real*8 (a-h,o-z)
2251 !      include 'DIMENSIONS'
2252       real(kind=8),parameter :: accur=1.0d-10
2253 !      include 'COMMON.GEO'
2254 !      include 'COMMON.VAR'
2255 !      include 'COMMON.LOCAL'
2256 !      include 'COMMON.CHAIN'
2257 !      include 'COMMON.DERIV'
2258 !      include 'COMMON.INTERACT'
2259 !      include 'COMMON.TORSION'
2260 !      include 'COMMON.SBRIDGE'
2261 !      include 'COMMON.NAMES'
2262 !      include 'COMMON.IOUNITS'
2263 !      include 'COMMON.CONTACTS'
2264       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2265 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2266 !el local variables
2267       integer :: i,iint,j,itypi,itypi1,itypj,k
2268       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2269       real(kind=8) :: fac
2270
2271       evdw=0.0D0
2272       do i=iatsc_s,iatsc_e
2273         itypi=iabs(itype(i,1))
2274         if (itypi.eq.ntyp1) cycle
2275         itypi1=iabs(itype(i+1,1))
2276         xi=c(1,nres+i)
2277         yi=c(2,nres+i)
2278         zi=c(3,nres+i)
2279 !
2280 ! Calculate SC interaction energy.
2281 !
2282         do iint=1,nint_gr(i)
2283 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2284 !d   &                  'iend=',iend(i,iint)
2285           do j=istart(i,iint),iend(i,iint)
2286             itypj=iabs(itype(j,1))
2287             if (itypj.eq.ntyp1) cycle
2288             xj=c(1,nres+j)-xi
2289             yj=c(2,nres+j)-yi
2290             zj=c(3,nres+j)-zi
2291             rij=xj*xj+yj*yj+zj*zj
2292 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2293             r0ij=r0(itypi,itypj)
2294             r0ijsq=r0ij*r0ij
2295 !            print *,i,j,r0ij,dsqrt(rij)
2296             if (rij.lt.r0ijsq) then
2297               evdwij=0.25d0*(rij-r0ijsq)**2
2298               fac=rij-r0ijsq
2299             else
2300               evdwij=0.0d0
2301               fac=0.0d0
2302             endif
2303             evdw=evdw+evdwij
2304 !
2305 ! Calculate the components of the gradient in DC and X
2306 !
2307             gg(1)=xj*fac
2308             gg(2)=yj*fac
2309             gg(3)=zj*fac
2310             do k=1,3
2311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2315             enddo
2316 !grad            do k=i,j-1
2317 !grad              do l=1,3
2318 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2319 !grad              enddo
2320 !grad            enddo
2321           enddo ! j
2322         enddo ! iint
2323       enddo ! i
2324       return
2325       end subroutine e_softsphere
2326 !-----------------------------------------------------------------------------
2327       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2328 !
2329 ! Soft-sphere potential of p-p interaction
2330 !
2331 !      implicit real*8 (a-h,o-z)
2332 !      include 'DIMENSIONS'
2333 !      include 'COMMON.CONTROL'
2334 !      include 'COMMON.IOUNITS'
2335 !      include 'COMMON.GEO'
2336 !      include 'COMMON.VAR'
2337 !      include 'COMMON.LOCAL'
2338 !      include 'COMMON.CHAIN'
2339 !      include 'COMMON.DERIV'
2340 !      include 'COMMON.INTERACT'
2341 !      include 'COMMON.CONTACTS'
2342 !      include 'COMMON.TORSION'
2343 !      include 'COMMON.VECTORS'
2344 !      include 'COMMON.FFIELD'
2345       real(kind=8),dimension(3) :: ggg
2346 !d      write(iout,*) 'In EELEC_soft_sphere'
2347 !el local variables
2348       integer :: i,j,k,num_conti,iteli,itelj
2349       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2350       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2351       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2352
2353       ees=0.0D0
2354       evdw1=0.0D0
2355       eel_loc=0.0d0
2356       eello_turn3=0.0d0
2357       eello_turn4=0.0d0
2358 !el      ind=0
2359       do i=iatel_s,iatel_e
2360         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2361         dxi=dc(1,i)
2362         dyi=dc(2,i)
2363         dzi=dc(3,i)
2364         xmedi=c(1,i)+0.5d0*dxi
2365         ymedi=c(2,i)+0.5d0*dyi
2366         zmedi=c(3,i)+0.5d0*dzi
2367         num_conti=0
2368 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2369         do j=ielstart(i),ielend(i)
2370           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2371 !el          ind=ind+1
2372           iteli=itel(i)
2373           itelj=itel(j)
2374           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2375           r0ij=rpp(iteli,itelj)
2376           r0ijsq=r0ij*r0ij
2377           dxj=dc(1,j)
2378           dyj=dc(2,j)
2379           dzj=dc(3,j)
2380           xj=c(1,j)+0.5D0*dxj-xmedi
2381           yj=c(2,j)+0.5D0*dyj-ymedi
2382           zj=c(3,j)+0.5D0*dzj-zmedi
2383           rij=xj*xj+yj*yj+zj*zj
2384           if (rij.lt.r0ijsq) then
2385             evdw1ij=0.25d0*(rij-r0ijsq)**2
2386             fac=rij-r0ijsq
2387           else
2388             evdw1ij=0.0d0
2389             fac=0.0d0
2390           endif
2391           evdw1=evdw1+evdw1ij
2392 !
2393 ! Calculate contributions to the Cartesian gradient.
2394 !
2395           ggg(1)=fac*xj
2396           ggg(2)=fac*yj
2397           ggg(3)=fac*zj
2398           do k=1,3
2399             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2400             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2401           enddo
2402 !
2403 ! Loop over residues i+1 thru j-1.
2404 !
2405 !grad          do k=i+1,j-1
2406 !grad            do l=1,3
2407 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2408 !grad            enddo
2409 !grad          enddo
2410         enddo ! j
2411       enddo   ! i
2412 !grad      do i=nnt,nct-1
2413 !grad        do k=1,3
2414 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2415 !grad        enddo
2416 !grad        do j=i+1,nct-1
2417 !grad          do k=1,3
2418 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2419 !grad          enddo
2420 !grad        enddo
2421 !grad      enddo
2422       return
2423       end subroutine eelec_soft_sphere
2424 !-----------------------------------------------------------------------------
2425       subroutine vec_and_deriv
2426 !      implicit real*8 (a-h,o-z)
2427 !      include 'DIMENSIONS'
2428 #ifdef MPI
2429       include 'mpif.h'
2430 #endif
2431 !      include 'COMMON.IOUNITS'
2432 !      include 'COMMON.GEO'
2433 !      include 'COMMON.VAR'
2434 !      include 'COMMON.LOCAL'
2435 !      include 'COMMON.CHAIN'
2436 !      include 'COMMON.VECTORS'
2437 !      include 'COMMON.SETUP'
2438 !      include 'COMMON.TIME1'
2439       real(kind=8),dimension(3,3,2) :: uyder,uzder
2440       real(kind=8),dimension(2) :: vbld_inv_temp
2441 ! Compute the local reference systems. For reference system (i), the
2442 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2443 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2444 !el local variables
2445       integer :: i,j,k,l
2446       real(kind=8) :: facy,fac,costh
2447
2448 #ifdef PARVEC
2449       do i=ivec_start,ivec_end
2450 #else
2451       do i=1,nres-1
2452 #endif
2453           if (i.eq.nres-1) then
2454 ! Case of the last full residue
2455 ! Compute the Z-axis
2456             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2457             costh=dcos(pi-theta(nres))
2458             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2459             do k=1,3
2460               uz(k,i)=fac*uz(k,i)
2461             enddo
2462 ! Compute the derivatives of uz
2463             uzder(1,1,1)= 0.0d0
2464             uzder(2,1,1)=-dc_norm(3,i-1)
2465             uzder(3,1,1)= dc_norm(2,i-1)
2466             uzder(1,2,1)= dc_norm(3,i-1)
2467             uzder(2,2,1)= 0.0d0
2468             uzder(3,2,1)=-dc_norm(1,i-1)
2469             uzder(1,3,1)=-dc_norm(2,i-1)
2470             uzder(2,3,1)= dc_norm(1,i-1)
2471             uzder(3,3,1)= 0.0d0
2472             uzder(1,1,2)= 0.0d0
2473             uzder(2,1,2)= dc_norm(3,i)
2474             uzder(3,1,2)=-dc_norm(2,i)
2475             uzder(1,2,2)=-dc_norm(3,i)
2476             uzder(2,2,2)= 0.0d0
2477             uzder(3,2,2)= dc_norm(1,i)
2478             uzder(1,3,2)= dc_norm(2,i)
2479             uzder(2,3,2)=-dc_norm(1,i)
2480             uzder(3,3,2)= 0.0d0
2481 ! Compute the Y-axis
2482             facy=fac
2483             do k=1,3
2484               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2485             enddo
2486 ! Compute the derivatives of uy
2487             do j=1,3
2488               do k=1,3
2489                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2490                               -dc_norm(k,i)*dc_norm(j,i-1)
2491                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2492               enddo
2493               uyder(j,j,1)=uyder(j,j,1)-costh
2494               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2495             enddo
2496             do j=1,2
2497               do k=1,3
2498                 do l=1,3
2499                   uygrad(l,k,j,i)=uyder(l,k,j)
2500                   uzgrad(l,k,j,i)=uzder(l,k,j)
2501                 enddo
2502               enddo
2503             enddo
2504             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2505             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2506             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2507             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2508           else
2509 ! Other residues
2510 ! Compute the Z-axis
2511             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2512             costh=dcos(pi-theta(i+2))
2513             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2514             do k=1,3
2515               uz(k,i)=fac*uz(k,i)
2516             enddo
2517 ! Compute the derivatives of uz
2518             uzder(1,1,1)= 0.0d0
2519             uzder(2,1,1)=-dc_norm(3,i+1)
2520             uzder(3,1,1)= dc_norm(2,i+1)
2521             uzder(1,2,1)= dc_norm(3,i+1)
2522             uzder(2,2,1)= 0.0d0
2523             uzder(3,2,1)=-dc_norm(1,i+1)
2524             uzder(1,3,1)=-dc_norm(2,i+1)
2525             uzder(2,3,1)= dc_norm(1,i+1)
2526             uzder(3,3,1)= 0.0d0
2527             uzder(1,1,2)= 0.0d0
2528             uzder(2,1,2)= dc_norm(3,i)
2529             uzder(3,1,2)=-dc_norm(2,i)
2530             uzder(1,2,2)=-dc_norm(3,i)
2531             uzder(2,2,2)= 0.0d0
2532             uzder(3,2,2)= dc_norm(1,i)
2533             uzder(1,3,2)= dc_norm(2,i)
2534             uzder(2,3,2)=-dc_norm(1,i)
2535             uzder(3,3,2)= 0.0d0
2536 ! Compute the Y-axis
2537             facy=fac
2538             do k=1,3
2539               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2540             enddo
2541 ! Compute the derivatives of uy
2542             do j=1,3
2543               do k=1,3
2544                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2545                               -dc_norm(k,i)*dc_norm(j,i+1)
2546                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2547               enddo
2548               uyder(j,j,1)=uyder(j,j,1)-costh
2549               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2550             enddo
2551             do j=1,2
2552               do k=1,3
2553                 do l=1,3
2554                   uygrad(l,k,j,i)=uyder(l,k,j)
2555                   uzgrad(l,k,j,i)=uzder(l,k,j)
2556                 enddo
2557               enddo
2558             enddo
2559             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2560             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2561             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2562             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2563           endif
2564       enddo
2565       do i=1,nres-1
2566         vbld_inv_temp(1)=vbld_inv(i+1)
2567         if (i.lt.nres-1) then
2568           vbld_inv_temp(2)=vbld_inv(i+2)
2569           else
2570           vbld_inv_temp(2)=vbld_inv(i)
2571           endif
2572         do j=1,2
2573           do k=1,3
2574             do l=1,3
2575               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2576               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2577             enddo
2578           enddo
2579         enddo
2580       enddo
2581 #if defined(PARVEC) && defined(MPI)
2582       if (nfgtasks1.gt.1) then
2583         time00=MPI_Wtime()
2584 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2585 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2586 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2587         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2588          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2589          FG_COMM1,IERR)
2590         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2591          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2592          FG_COMM1,IERR)
2593         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2594          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2595          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2596         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2597          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2598          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2599         time_gather=time_gather+MPI_Wtime()-time00
2600       endif
2601 !      if (fg_rank.eq.0) then
2602 !        write (iout,*) "Arrays UY and UZ"
2603 !        do i=1,nres-1
2604 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2605 !     &     (uz(k,i),k=1,3)
2606 !        enddo
2607 !      endif
2608 #endif
2609       return
2610       end subroutine vec_and_deriv
2611 !-----------------------------------------------------------------------------
2612       subroutine check_vecgrad
2613 !      implicit real*8 (a-h,o-z)
2614 !      include 'DIMENSIONS'
2615 !      include 'COMMON.IOUNITS'
2616 !      include 'COMMON.GEO'
2617 !      include 'COMMON.VAR'
2618 !      include 'COMMON.LOCAL'
2619 !      include 'COMMON.CHAIN'
2620 !      include 'COMMON.VECTORS'
2621       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2622       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2623       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2624       real(kind=8),dimension(3) :: erij
2625       real(kind=8) :: delta=1.0d-7
2626 !el local variables
2627       integer :: i,j,k,l
2628
2629       call vec_and_deriv
2630 !d      do i=1,nres
2631 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2632 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2633 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2634 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2635 !d     &     (dc_norm(if90,i),if90=1,3)
2636 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2637 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2638 !d          write(iout,'(a)')
2639 !d      enddo
2640       do i=1,nres
2641         do j=1,2
2642           do k=1,3
2643             do l=1,3
2644               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2645               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2646             enddo
2647           enddo
2648         enddo
2649       enddo
2650       call vec_and_deriv
2651       do i=1,nres
2652         do j=1,3
2653           uyt(j,i)=uy(j,i)
2654           uzt(j,i)=uz(j,i)
2655         enddo
2656       enddo
2657       do i=1,nres
2658 !d        write (iout,*) 'i=',i
2659         do k=1,3
2660           erij(k)=dc_norm(k,i)
2661         enddo
2662         do j=1,3
2663           do k=1,3
2664             dc_norm(k,i)=erij(k)
2665           enddo
2666           dc_norm(j,i)=dc_norm(j,i)+delta
2667 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2668 !          do k=1,3
2669 !            dc_norm(k,i)=dc_norm(k,i)/fac
2670 !          enddo
2671 !          write (iout,*) (dc_norm(k,i),k=1,3)
2672 !          write (iout,*) (erij(k),k=1,3)
2673           call vec_and_deriv
2674           do k=1,3
2675             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2676             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2677             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2678             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2679           enddo
2680 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2681 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2682 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2683         enddo
2684         do k=1,3
2685           dc_norm(k,i)=erij(k)
2686         enddo
2687 !d        do k=1,3
2688 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2689 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2690 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2691 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2692 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2693 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2694 !d          write (iout,'(a)')
2695 !d        enddo
2696       enddo
2697       return
2698       end subroutine check_vecgrad
2699 !-----------------------------------------------------------------------------
2700       subroutine set_matrices
2701 !      implicit real*8 (a-h,o-z)
2702 !      include 'DIMENSIONS'
2703 #ifdef MPI
2704       include "mpif.h"
2705 !      include "COMMON.SETUP"
2706       integer :: IERR
2707       integer :: status(MPI_STATUS_SIZE)
2708 #endif
2709 !      include 'COMMON.IOUNITS'
2710 !      include 'COMMON.GEO'
2711 !      include 'COMMON.VAR'
2712 !      include 'COMMON.LOCAL'
2713 !      include 'COMMON.CHAIN'
2714 !      include 'COMMON.DERIV'
2715 !      include 'COMMON.INTERACT'
2716 !      include 'COMMON.CONTACTS'
2717 !      include 'COMMON.TORSION'
2718 !      include 'COMMON.VECTORS'
2719 !      include 'COMMON.FFIELD'
2720       real(kind=8) :: auxvec(2),auxmat(2,2)
2721       integer :: i,iti1,iti,k,l
2722       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2723        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2724 !       print *,"in set matrices"
2725 !
2726 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2727 ! to calculate the el-loc multibody terms of various order.
2728 !
2729 !AL el      mu=0.0d0
2730 #ifdef PARMAT
2731       do i=ivec_start+2,ivec_end+2
2732 #else
2733       do i=3,nres+1
2734 #endif
2735         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2736           iti = itype2loc(itype(i-2,1))
2737         else
2738           iti=nloctyp
2739         endif
2740 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2741         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2742           iti1 = itype2loc(itype(i-1,1))
2743         else
2744           iti1=nloctyp
2745         endif
2746 !        print *,i,itype(i-2,1),iti
2747 #ifdef NEWCORR
2748         cost1=dcos(theta(i-1))
2749         sint1=dsin(theta(i-1))
2750         sint1sq=sint1*sint1
2751         sint1cub=sint1sq*sint1
2752         sint1cost1=2*sint1*cost1
2753 !        print *,"cost1",cost1,theta(i-1)
2754 !c        write (iout,*) "bnew1",i,iti
2755 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2756 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2757 !c        write (iout,*) "bnew2",i,iti
2758 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2759 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2760         k=1
2761 !        print *,bnew1(1,k,iti),"bnew1"
2762         do k=1,2
2763           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2764 !          print *,b1k
2765 !          write(*,*) shape(b1)
2766 !          if(.not.allocated(b1)) print *, "WTF?"
2767           b1(k,i-2)=sint1*b1k
2768 !
2769 !             print *,b1(k,i-2)
2770
2771           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2772                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2773 !             print *,gtb1(k,i-2)
2774
2775           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2776           b2(k,i-2)=sint1*b2k
2777 !             print *,b2(k,i-2)
2778
2779           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2780                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2781 !             print *,gtb2(k,i-2)
2782
2783         enddo
2784 !        print *,b1k,b2k
2785         do k=1,2
2786           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2787           cc(1,k,i-2)=sint1sq*aux
2788           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2789                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2790           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2791           dd(1,k,i-2)=sint1sq*aux
2792           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2793                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2794         enddo
2795 !        print *,"after cc"
2796         cc(2,1,i-2)=cc(1,2,i-2)
2797         cc(2,2,i-2)=-cc(1,1,i-2)
2798         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2799         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2800         dd(2,1,i-2)=dd(1,2,i-2)
2801         dd(2,2,i-2)=-dd(1,1,i-2)
2802         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2803         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2804 !        print *,"after dd"
2805
2806         do k=1,2
2807           do l=1,2
2808             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2809             EE(l,k,i-2)=sint1sq*aux
2810             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2811           enddo
2812         enddo
2813         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2814         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2815         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2816         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2817         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2818         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2819         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2820 !        print *,"after ee"
2821
2822 !c        b1tilde(1,i-2)=b1(1,i-2)
2823 !c        b1tilde(2,i-2)=-b1(2,i-2)
2824 !c        b2tilde(1,i-2)=b2(1,i-2)
2825 !c        b2tilde(2,i-2)=-b2(2,i-2)
2826 #ifdef DEBUG
2827         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2828         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2829         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2830         write (iout,*) 'theta=', theta(i-1)
2831 #endif
2832 #else
2833         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2834           iti = itype2loc(itype(i-2,1))
2835         else
2836           iti=nloctyp
2837         endif
2838 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2839 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2840         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2841           iti1 = itype2loc(itype(i-1,1))
2842         else
2843           iti1=nloctyp
2844         endif
2845         b1(1,i-2)=b(3,iti)
2846         b1(2,i-2)=b(5,iti)
2847         b2(1,i-2)=b(2,iti)
2848         b2(2,i-2)=b(4,iti)
2849         do k=1,2
2850           do l=1,2
2851            CC(k,l,i-2)=ccold(k,l,iti)
2852            DD(k,l,i-2)=ddold(k,l,iti)
2853            EE(k,l,i-2)=eeold(k,l,iti)
2854           enddo
2855         enddo
2856 #endif
2857         b1tilde(1,i-2)= b1(1,i-2)
2858         b1tilde(2,i-2)=-b1(2,i-2)
2859         b2tilde(1,i-2)= b2(1,i-2)
2860         b2tilde(2,i-2)=-b2(2,i-2)
2861 !c
2862         Ctilde(1,1,i-2)= CC(1,1,i-2)
2863         Ctilde(1,2,i-2)= CC(1,2,i-2)
2864         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2865         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2866 !c
2867         Dtilde(1,1,i-2)= DD(1,1,i-2)
2868         Dtilde(1,2,i-2)= DD(1,2,i-2)
2869         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2870         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2871       enddo
2872 #ifdef PARMAT
2873       do i=ivec_start+2,ivec_end+2
2874 #else
2875       do i=3,nres+1
2876 #endif
2877
2878 !      print *,i,"i"
2879         if (i .lt. nres+1) then
2880           sin1=dsin(phi(i))
2881           cos1=dcos(phi(i))
2882           sintab(i-2)=sin1
2883           costab(i-2)=cos1
2884           obrot(1,i-2)=cos1
2885           obrot(2,i-2)=sin1
2886           sin2=dsin(2*phi(i))
2887           cos2=dcos(2*phi(i))
2888           sintab2(i-2)=sin2
2889           costab2(i-2)=cos2
2890           obrot2(1,i-2)=cos2
2891           obrot2(2,i-2)=sin2
2892           Ug(1,1,i-2)=-cos1
2893           Ug(1,2,i-2)=-sin1
2894           Ug(2,1,i-2)=-sin1
2895           Ug(2,2,i-2)= cos1
2896           Ug2(1,1,i-2)=-cos2
2897           Ug2(1,2,i-2)=-sin2
2898           Ug2(2,1,i-2)=-sin2
2899           Ug2(2,2,i-2)= cos2
2900         else
2901           costab(i-2)=1.0d0
2902           sintab(i-2)=0.0d0
2903           obrot(1,i-2)=1.0d0
2904           obrot(2,i-2)=0.0d0
2905           obrot2(1,i-2)=0.0d0
2906           obrot2(2,i-2)=0.0d0
2907           Ug(1,1,i-2)=1.0d0
2908           Ug(1,2,i-2)=0.0d0
2909           Ug(2,1,i-2)=0.0d0
2910           Ug(2,2,i-2)=1.0d0
2911           Ug2(1,1,i-2)=0.0d0
2912           Ug2(1,2,i-2)=0.0d0
2913           Ug2(2,1,i-2)=0.0d0
2914           Ug2(2,2,i-2)=0.0d0
2915         endif
2916         if (i .gt. 3 .and. i .lt. nres+1) then
2917           obrot_der(1,i-2)=-sin1
2918           obrot_der(2,i-2)= cos1
2919           Ugder(1,1,i-2)= sin1
2920           Ugder(1,2,i-2)=-cos1
2921           Ugder(2,1,i-2)=-cos1
2922           Ugder(2,2,i-2)=-sin1
2923           dwacos2=cos2+cos2
2924           dwasin2=sin2+sin2
2925           obrot2_der(1,i-2)=-dwasin2
2926           obrot2_der(2,i-2)= dwacos2
2927           Ug2der(1,1,i-2)= dwasin2
2928           Ug2der(1,2,i-2)=-dwacos2
2929           Ug2der(2,1,i-2)=-dwacos2
2930           Ug2der(2,2,i-2)=-dwasin2
2931         else
2932           obrot_der(1,i-2)=0.0d0
2933           obrot_der(2,i-2)=0.0d0
2934           Ugder(1,1,i-2)=0.0d0
2935           Ugder(1,2,i-2)=0.0d0
2936           Ugder(2,1,i-2)=0.0d0
2937           Ugder(2,2,i-2)=0.0d0
2938           obrot2_der(1,i-2)=0.0d0
2939           obrot2_der(2,i-2)=0.0d0
2940           Ug2der(1,1,i-2)=0.0d0
2941           Ug2der(1,2,i-2)=0.0d0
2942           Ug2der(2,1,i-2)=0.0d0
2943           Ug2der(2,2,i-2)=0.0d0
2944         endif
2945 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2946         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2947            if (itype(i-2,1).eq.0) then
2948           iti=ntortyp+1
2949            else
2950           iti = itype2loc(itype(i-2,1))
2951            endif
2952         else
2953           iti=nloctyp
2954         endif
2955 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2956         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2957            if (itype(i-1,1).eq.0) then
2958           iti1=nloctyp
2959            else
2960           iti1 = itype2loc(itype(i-1,1))
2961            endif
2962         else
2963           iti1=nloctyp
2964         endif
2965 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2966 !d        write (iout,*) '*******i',i,' iti1',iti
2967 !        write (iout,*) 'b1',b1(:,iti)
2968 !        write (iout,*) 'b2',b2(:,i-2)
2969 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2970 !        if (i .gt. iatel_s+2) then
2971         if (i .gt. nnt+2) then
2972           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2973 #ifdef NEWCORR
2974           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2975 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2976 #endif
2977
2978           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2979           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2980           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2981           then
2982           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2983           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2984           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2985           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2986           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2987           endif
2988         else
2989           do k=1,2
2990             Ub2(k,i-2)=0.0d0
2991             Ctobr(k,i-2)=0.0d0
2992             Dtobr2(k,i-2)=0.0d0
2993             do l=1,2
2994               EUg(l,k,i-2)=0.0d0
2995               CUg(l,k,i-2)=0.0d0
2996               DUg(l,k,i-2)=0.0d0
2997               DtUg2(l,k,i-2)=0.0d0
2998             enddo
2999           enddo
3000         endif
3001         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3002         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3003         do k=1,2
3004           muder(k,i-2)=Ub2der(k,i-2)
3005         enddo
3006 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3007         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3008           if (itype(i-1,1).eq.0) then
3009            iti1=ntortyp+1
3010           elseif (itype(i-1,1).le.ntyp) then
3011             iti1 = itype2loc(itype(i-1,1))
3012           else
3013             iti1=nloctyp
3014           endif
3015         else
3016           iti1=nloctyp
3017         endif
3018         do k=1,2
3019           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3020         enddo
3021         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3022         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3023         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3024 !d        write (iout,*) 'mu1',mu1(:,i-2)
3025 !d        write (iout,*) 'mu2',mu2(:,i-2)
3026         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3027         then
3028         call matmat2(CC(1,1,i-2),Ugder(1,1,i-2),CUgder(1,1,i-2))
3029         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3030         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3031         call matvec2(Ctilde(1,1,i-2),obrot_der(1,i-2),Ctobrder(1,i-2))
3032         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3033 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3034         call matvec2(DD(1,1,i-2),b1tilde(1,iti1),auxvec(1))
3035         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3036         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3037         call matvec2(CC(1,1,i-2),Ub2(1,i-2),CUgb2(1,i-2))
3038         call matvec2(CC(1,1,i-2),Ub2der(1,i-2),CUgb2der(1,i-2))
3039         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3040         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3041         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3042         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3043         endif
3044       enddo
3045 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3046 ! The order of matrices is from left to right.
3047       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3048       then
3049 !      do i=max0(ivec_start,2),ivec_end
3050       do i=2,nres-1
3051         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3052         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3053         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3054         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3055         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3056         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3057         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3058         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3059       enddo
3060       endif
3061 #if defined(MPI) && defined(PARMAT)
3062 #ifdef DEBUG
3063 !      if (fg_rank.eq.0) then
3064         write (iout,*) "Arrays UG and UGDER before GATHER"
3065         do i=1,nres-1
3066           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3067            ((ug(l,k,i),l=1,2),k=1,2),&
3068            ((ugder(l,k,i),l=1,2),k=1,2)
3069         enddo
3070         write (iout,*) "Arrays UG2 and UG2DER"
3071         do i=1,nres-1
3072           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3073            ((ug2(l,k,i),l=1,2),k=1,2),&
3074            ((ug2der(l,k,i),l=1,2),k=1,2)
3075         enddo
3076         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3077         do i=1,nres-1
3078           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3079            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3080            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3081         enddo
3082         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3083         do i=1,nres-1
3084           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3085            costab(i),sintab(i),costab2(i),sintab2(i)
3086         enddo
3087         write (iout,*) "Array MUDER"
3088         do i=1,nres-1
3089           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3090         enddo
3091 !      endif
3092 #endif
3093       if (nfgtasks.gt.1) then
3094         time00=MPI_Wtime()
3095 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3096 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3097 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3098 #ifdef MATGATHER
3099         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3100          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3101          FG_COMM1,IERR)
3102         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3103          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3104          FG_COMM1,IERR)
3105         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3106          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3107          FG_COMM1,IERR)
3108         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3109          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3110          FG_COMM1,IERR)
3111         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3112          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3113          FG_COMM1,IERR)
3114         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3115          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3116          FG_COMM1,IERR)
3117         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3118          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3119          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3120         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3121          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3122          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3123         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3124          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3125          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3126         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3127          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3128          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3129         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3130         then
3131         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3132          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3133          FG_COMM1,IERR)
3134         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3135          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3136          FG_COMM1,IERR)
3137         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3138          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3139          FG_COMM1,IERR)
3140        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3141          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3142          FG_COMM1,IERR)
3143         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3144          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3145          FG_COMM1,IERR)
3146         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3147          ivec_count(fg_rank1),&
3148          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3149          FG_COMM1,IERR)
3150         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3151          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3152          FG_COMM1,IERR)
3153         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3154          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3155          FG_COMM1,IERR)
3156         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3157          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3158          FG_COMM1,IERR)
3159         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3160          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3161          FG_COMM1,IERR)
3162         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3163          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3164          FG_COMM1,IERR)
3165         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3166          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3167          FG_COMM1,IERR)
3168         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3169          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3170          FG_COMM1,IERR)
3171         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3172          ivec_count(fg_rank1),&
3173          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3174          FG_COMM1,IERR)
3175         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3176          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3177          FG_COMM1,IERR)
3178        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3179          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3180          FG_COMM1,IERR)
3181         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3182          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3183          FG_COMM1,IERR)
3184        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3185          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3188          ivec_count(fg_rank1),&
3189          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3190          FG_COMM1,IERR)
3191         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3192          ivec_count(fg_rank1),&
3193          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3194          FG_COMM1,IERR)
3195         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3196          ivec_count(fg_rank1),&
3197          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3198          MPI_MAT2,FG_COMM1,IERR)
3199         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3200          ivec_count(fg_rank1),&
3201          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3202          MPI_MAT2,FG_COMM1,IERR)
3203         endif
3204 #else
3205 ! Passes matrix info through the ring
3206       isend=fg_rank1
3207       irecv=fg_rank1-1
3208       if (irecv.lt.0) irecv=nfgtasks1-1
3209       iprev=irecv
3210       inext=fg_rank1+1
3211       if (inext.ge.nfgtasks1) inext=0
3212       do i=1,nfgtasks1-1
3213 !        write (iout,*) "isend",isend," irecv",irecv
3214 !        call flush(iout)
3215         lensend=lentyp(isend)
3216         lenrecv=lentyp(irecv)
3217 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3218 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3219 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3220 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3221 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3222 !        write (iout,*) "Gather ROTAT1"
3223 !        call flush(iout)
3224 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3225 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3226 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3227 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3228 !        write (iout,*) "Gather ROTAT2"
3229 !        call flush(iout)
3230         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3231          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3232          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3233          iprev,4400+irecv,FG_COMM,status,IERR)
3234 !        write (iout,*) "Gather ROTAT_OLD"
3235 !        call flush(iout)
3236         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3237          MPI_PRECOMP11(lensend),inext,5500+isend,&
3238          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3239          iprev,5500+irecv,FG_COMM,status,IERR)
3240 !        write (iout,*) "Gather PRECOMP11"
3241 !        call flush(iout)
3242         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3243          MPI_PRECOMP12(lensend),inext,6600+isend,&
3244          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3245          iprev,6600+irecv,FG_COMM,status,IERR)
3246 !        write (iout,*) "Gather PRECOMP12"
3247 !        call flush(iout)
3248         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3249         then
3250         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3251          MPI_ROTAT2(lensend),inext,7700+isend,&
3252          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3253          iprev,7700+irecv,FG_COMM,status,IERR)
3254 !        write (iout,*) "Gather PRECOMP21"
3255 !        call flush(iout)
3256         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3257          MPI_PRECOMP22(lensend),inext,8800+isend,&
3258          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3259          iprev,8800+irecv,FG_COMM,status,IERR)
3260 !        write (iout,*) "Gather PRECOMP22"
3261 !        call flush(iout)
3262         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3263          MPI_PRECOMP23(lensend),inext,9900+isend,&
3264          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3265          MPI_PRECOMP23(lenrecv),&
3266          iprev,9900+irecv,FG_COMM,status,IERR)
3267 !        write (iout,*) "Gather PRECOMP23"
3268 !        call flush(iout)
3269         endif
3270         isend=irecv
3271         irecv=irecv-1
3272         if (irecv.lt.0) irecv=nfgtasks1-1
3273       enddo
3274 #endif
3275         time_gather=time_gather+MPI_Wtime()-time00
3276       endif
3277 #ifdef DEBUG
3278 !      if (fg_rank.eq.0) then
3279         write (iout,*) "Arrays UG and UGDER"
3280         do i=1,nres-1
3281           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3282            ((ug(l,k,i),l=1,2),k=1,2),&
3283            ((ugder(l,k,i),l=1,2),k=1,2)
3284         enddo
3285         write (iout,*) "Arrays UG2 and UG2DER"
3286         do i=1,nres-1
3287           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3288            ((ug2(l,k,i),l=1,2),k=1,2),&
3289            ((ug2der(l,k,i),l=1,2),k=1,2)
3290         enddo
3291         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3294            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3295            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3300            costab(i),sintab(i),costab2(i),sintab2(i)
3301         enddo
3302         write (iout,*) "Array MUDER"
3303         do i=1,nres-1
3304           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3305         enddo
3306 !      endif
3307 #endif
3308 #endif
3309 !d      do i=1,nres
3310 !d        iti = itortyp(itype(i,1))
3311 !d        write (iout,*) i
3312 !d        do j=1,2
3313 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3314 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3315 !d        enddo
3316 !d      enddo
3317       return
3318       end subroutine set_matrices
3319 !-----------------------------------------------------------------------------
3320       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3321 !
3322 ! This subroutine calculates the average interaction energy and its gradient
3323 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3324 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3325 ! The potential depends both on the distance of peptide-group centers and on
3326 ! the orientation of the CA-CA virtual bonds.
3327 !
3328       use comm_locel
3329 !      implicit real*8 (a-h,o-z)
3330 #ifdef MPI
3331       include 'mpif.h'
3332 #endif
3333 !      include 'DIMENSIONS'
3334 !      include 'COMMON.CONTROL'
3335 !      include 'COMMON.SETUP'
3336 !      include 'COMMON.IOUNITS'
3337 !      include 'COMMON.GEO'
3338 !      include 'COMMON.VAR'
3339 !      include 'COMMON.LOCAL'
3340 !      include 'COMMON.CHAIN'
3341 !      include 'COMMON.DERIV'
3342 !      include 'COMMON.INTERACT'
3343 !      include 'COMMON.CONTACTS'
3344 !      include 'COMMON.TORSION'
3345 !      include 'COMMON.VECTORS'
3346 !      include 'COMMON.FFIELD'
3347 !      include 'COMMON.TIME1'
3348       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3349       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3350       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3351 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3352       real(kind=8),dimension(4) :: muij
3353 !el      integer :: num_conti,j1,j2
3354 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3355 !el        dz_normi,xmedi,ymedi,zmedi
3356
3357 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3358 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3359 !el          num_conti,j1,j2
3360
3361 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3362 #ifdef MOMENT
3363       real(kind=8) :: scal_el=1.0d0
3364 #else
3365       real(kind=8) :: scal_el=0.5d0
3366 #endif
3367 ! 12/13/98
3368 ! 13-go grudnia roku pamietnego...
3369       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3370                                              0.0d0,1.0d0,0.0d0,&
3371                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3372 !el local variables
3373       integer :: i,k,j
3374       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3375       real(kind=8) :: fac,t_eelecij,fracinbuf
3376
3377
3378 !d      write(iout,*) 'In EELEC'
3379 !        print *,"IN EELEC"
3380 !d      do i=1,nloctyp
3381 !d        write(iout,*) 'Type',i
3382 !d        write(iout,*) 'B1',B1(:,i)
3383 !d        write(iout,*) 'B2',B2(:,i)
3384 !d        write(iout,*) 'CC',CC(:,:,i)
3385 !d        write(iout,*) 'DD',DD(:,:,i)
3386 !d        write(iout,*) 'EE',EE(:,:,i)
3387 !d      enddo
3388 !d      call check_vecgrad
3389 !d      stop
3390 !      ees=0.0d0  !AS
3391 !      evdw1=0.0d0
3392 !      eel_loc=0.0d0
3393 !      eello_turn3=0.0d0
3394 !      eello_turn4=0.0d0
3395       t_eelecij=0.0d0
3396       ees=0.0D0
3397       evdw1=0.0D0
3398       eel_loc=0.0d0
3399       eello_turn3=0.0d0
3400       eello_turn4=0.0d0
3401 !
3402
3403       if (icheckgrad.eq.1) then
3404 !el
3405 !        do i=0,2*nres+2
3406 !          dc_norm(1,i)=0.0d0
3407 !          dc_norm(2,i)=0.0d0
3408 !          dc_norm(3,i)=0.0d0
3409 !        enddo
3410         do i=1,nres-1
3411           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3412           do k=1,3
3413             dc_norm(k,i)=dc(k,i)*fac
3414           enddo
3415 !          write (iout,*) 'i',i,' fac',fac
3416         enddo
3417       endif
3418 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3419 !        wturn6
3420       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3421           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3422           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3423 !        call vec_and_deriv
3424 #ifdef TIMING
3425         time01=MPI_Wtime()
3426 #endif
3427 !        print *, "before set matrices"
3428         call set_matrices
3429 !        print *, "after set matrices"
3430
3431 #ifdef TIMING
3432         time_mat=time_mat+MPI_Wtime()-time01
3433 #endif
3434       endif
3435 !       print *, "after set matrices"
3436 !d      do i=1,nres-1
3437 !d        write (iout,*) 'i=',i
3438 !d        do k=1,3
3439 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3440 !d        enddo
3441 !d        do k=1,3
3442 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3443 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3444 !d        enddo
3445 !d      enddo
3446       t_eelecij=0.0d0
3447       ees=0.0D0
3448       evdw1=0.0D0
3449       eel_loc=0.0d0
3450       eello_turn3=0.0d0
3451       eello_turn4=0.0d0
3452 !el      ind=0
3453       do i=1,nres
3454         num_cont_hb(i)=0
3455       enddo
3456 !d      print '(a)','Enter EELEC'
3457 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3458 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3459 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3460       do i=1,nres
3461         gel_loc_loc(i)=0.0d0
3462         gcorr_loc(i)=0.0d0
3463       enddo
3464 !
3465 !
3466 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3467 !
3468 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3469 !
3470
3471
3472 !        print *,"before iturn3 loop"
3473       do i=iturn3_start,iturn3_end
3474         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3475         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3476         dxi=dc(1,i)
3477         dyi=dc(2,i)
3478         dzi=dc(3,i)
3479         dx_normi=dc_norm(1,i)
3480         dy_normi=dc_norm(2,i)
3481         dz_normi=dc_norm(3,i)
3482         xmedi=c(1,i)+0.5d0*dxi
3483         ymedi=c(2,i)+0.5d0*dyi
3484         zmedi=c(3,i)+0.5d0*dzi
3485           xmedi=dmod(xmedi,boxxsize)
3486           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3487           ymedi=dmod(ymedi,boxysize)
3488           if (ymedi.lt.0) ymedi=ymedi+boxysize
3489           zmedi=dmod(zmedi,boxzsize)
3490           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3491         num_conti=0
3492        if ((zmedi.gt.bordlipbot) &
3493         .and.(zmedi.lt.bordliptop)) then
3494 !C the energy transfer exist
3495         if (zmedi.lt.buflipbot) then
3496 !C what fraction I am in
3497          fracinbuf=1.0d0- &
3498                ((zmedi-bordlipbot)/lipbufthick)
3499 !C lipbufthick is thickenes of lipid buffore
3500          sslipi=sscalelip(fracinbuf)
3501          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3502         elseif (zmedi.gt.bufliptop) then
3503          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3504          sslipi=sscalelip(fracinbuf)
3505          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3506         else
3507          sslipi=1.0d0
3508          ssgradlipi=0.0
3509         endif
3510        else
3511          sslipi=0.0d0
3512          ssgradlipi=0.0
3513        endif
3514 !       print *,i,sslipi,ssgradlipi
3515        call eelecij(i,i+2,ees,evdw1,eel_loc)
3516         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3517         num_cont_hb(i)=num_conti
3518       enddo
3519       do i=iturn4_start,iturn4_end
3520         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3521           .or. itype(i+3,1).eq.ntyp1 &
3522           .or. itype(i+4,1).eq.ntyp1) cycle
3523 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3524         dxi=dc(1,i)
3525         dyi=dc(2,i)
3526         dzi=dc(3,i)
3527         dx_normi=dc_norm(1,i)
3528         dy_normi=dc_norm(2,i)
3529         dz_normi=dc_norm(3,i)
3530         xmedi=c(1,i)+0.5d0*dxi
3531         ymedi=c(2,i)+0.5d0*dyi
3532         zmedi=c(3,i)+0.5d0*dzi
3533           xmedi=dmod(xmedi,boxxsize)
3534           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3535           ymedi=dmod(ymedi,boxysize)
3536           if (ymedi.lt.0) ymedi=ymedi+boxysize
3537           zmedi=dmod(zmedi,boxzsize)
3538           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3539        if ((zmedi.gt.bordlipbot)  &
3540        .and.(zmedi.lt.bordliptop)) then
3541 !C the energy transfer exist
3542         if (zmedi.lt.buflipbot) then
3543 !C what fraction I am in
3544          fracinbuf=1.0d0- &
3545              ((zmedi-bordlipbot)/lipbufthick)
3546 !C lipbufthick is thickenes of lipid buffore
3547          sslipi=sscalelip(fracinbuf)
3548          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3549         elseif (zmedi.gt.bufliptop) then
3550          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3551          sslipi=sscalelip(fracinbuf)
3552          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3553         else
3554          sslipi=1.0d0
3555          ssgradlipi=0.0
3556         endif
3557        else
3558          sslipi=0.0d0
3559          ssgradlipi=0.0
3560        endif
3561
3562         num_conti=num_cont_hb(i)
3563         call eelecij(i,i+3,ees,evdw1,eel_loc)
3564         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3565          call eturn4(i,eello_turn4)
3566 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3567         num_cont_hb(i)=num_conti
3568       enddo   ! i
3569 !
3570 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3571 !
3572 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3573       do i=iatel_s,iatel_e
3574         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3575         dxi=dc(1,i)
3576         dyi=dc(2,i)
3577         dzi=dc(3,i)
3578         dx_normi=dc_norm(1,i)
3579         dy_normi=dc_norm(2,i)
3580         dz_normi=dc_norm(3,i)
3581         xmedi=c(1,i)+0.5d0*dxi
3582         ymedi=c(2,i)+0.5d0*dyi
3583         zmedi=c(3,i)+0.5d0*dzi
3584           xmedi=dmod(xmedi,boxxsize)
3585           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3586           ymedi=dmod(ymedi,boxysize)
3587           if (ymedi.lt.0) ymedi=ymedi+boxysize
3588           zmedi=dmod(zmedi,boxzsize)
3589           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3590        if ((zmedi.gt.bordlipbot)  &
3591         .and.(zmedi.lt.bordliptop)) then
3592 !C the energy transfer exist
3593         if (zmedi.lt.buflipbot) then
3594 !C what fraction I am in
3595          fracinbuf=1.0d0- &
3596              ((zmedi-bordlipbot)/lipbufthick)
3597 !C lipbufthick is thickenes of lipid buffore
3598          sslipi=sscalelip(fracinbuf)
3599          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3600         elseif (zmedi.gt.bufliptop) then
3601          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3602          sslipi=sscalelip(fracinbuf)
3603          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3604         else
3605          sslipi=1.0d0
3606          ssgradlipi=0.0
3607         endif
3608        else
3609          sslipi=0.0d0
3610          ssgradlipi=0.0
3611        endif
3612
3613 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3614         num_conti=num_cont_hb(i)
3615         do j=ielstart(i),ielend(i)
3616 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3617           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3618           call eelecij(i,j,ees,evdw1,eel_loc)
3619         enddo ! j
3620         num_cont_hb(i)=num_conti
3621       enddo   ! i
3622 !      write (iout,*) "Number of loop steps in EELEC:",ind
3623 !d      do i=1,nres
3624 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3625 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3626 !d      enddo
3627 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3628 !cc      eel_loc=eel_loc+eello_turn3
3629 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3630       return
3631       end subroutine eelec
3632 !-----------------------------------------------------------------------------
3633       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3634
3635       use comm_locel
3636 !      implicit real*8 (a-h,o-z)
3637 !      include 'DIMENSIONS'
3638 #ifdef MPI
3639       include "mpif.h"
3640 #endif
3641 !      include 'COMMON.CONTROL'
3642 !      include 'COMMON.IOUNITS'
3643 !      include 'COMMON.GEO'
3644 !      include 'COMMON.VAR'
3645 !      include 'COMMON.LOCAL'
3646 !      include 'COMMON.CHAIN'
3647 !      include 'COMMON.DERIV'
3648 !      include 'COMMON.INTERACT'
3649 !      include 'COMMON.CONTACTS'
3650 !      include 'COMMON.TORSION'
3651 !      include 'COMMON.VECTORS'
3652 !      include 'COMMON.FFIELD'
3653 !      include 'COMMON.TIME1'
3654       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3655       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3656       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3657 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3658       real(kind=8),dimension(4) :: muij
3659       real(kind=8) :: geel_loc_ij,geel_loc_ji
3660       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3661                     dist_temp, dist_init,rlocshield,fracinbuf
3662       integer xshift,yshift,zshift,ilist,iresshield
3663 !el      integer :: num_conti,j1,j2
3664 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3665 !el        dz_normi,xmedi,ymedi,zmedi
3666
3667 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3668 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3669 !el          num_conti,j1,j2
3670
3671 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3672 #ifdef MOMENT
3673       real(kind=8) :: scal_el=1.0d0
3674 #else
3675       real(kind=8) :: scal_el=0.5d0
3676 #endif
3677 ! 12/13/98
3678 ! 13-go grudnia roku pamietnego...
3679       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3680                                              0.0d0,1.0d0,0.0d0,&
3681                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3682 !      integer :: maxconts=nres/4
3683 !el local variables
3684       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3685       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3686       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3687       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3688                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3689                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3690                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3691                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3692                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3693                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3694                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3695 !      maxconts=nres/4
3696 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3697 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3698
3699 !          time00=MPI_Wtime()
3700 !d      write (iout,*) "eelecij",i,j
3701 !          ind=ind+1
3702           iteli=itel(i)
3703           itelj=itel(j)
3704           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3705           aaa=app(iteli,itelj)
3706           bbb=bpp(iteli,itelj)
3707           ael6i=ael6(iteli,itelj)
3708           ael3i=ael3(iteli,itelj)
3709           dxj=dc(1,j)
3710           dyj=dc(2,j)
3711           dzj=dc(3,j)
3712           dx_normj=dc_norm(1,j)
3713           dy_normj=dc_norm(2,j)
3714           dz_normj=dc_norm(3,j)
3715 !          xj=c(1,j)+0.5D0*dxj-xmedi
3716 !          yj=c(2,j)+0.5D0*dyj-ymedi
3717 !          zj=c(3,j)+0.5D0*dzj-zmedi
3718           xj=c(1,j)+0.5D0*dxj
3719           yj=c(2,j)+0.5D0*dyj
3720           zj=c(3,j)+0.5D0*dzj
3721           xj=mod(xj,boxxsize)
3722           if (xj.lt.0) xj=xj+boxxsize
3723           yj=mod(yj,boxysize)
3724           if (yj.lt.0) yj=yj+boxysize
3725           zj=mod(zj,boxzsize)
3726           if (zj.lt.0) zj=zj+boxzsize
3727        if ((zj.gt.bordlipbot)  &
3728        .and.(zj.lt.bordliptop)) then
3729 !C the energy transfer exist
3730         if (zj.lt.buflipbot) then
3731 !C what fraction I am in
3732          fracinbuf=1.0d0-     &
3733              ((zj-bordlipbot)/lipbufthick)
3734 !C lipbufthick is thickenes of lipid buffore
3735          sslipj=sscalelip(fracinbuf)
3736          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3737         elseif (zj.gt.bufliptop) then
3738          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3739          sslipj=sscalelip(fracinbuf)
3740          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3741         else
3742          sslipj=1.0d0
3743          ssgradlipj=0.0
3744         endif
3745        else
3746          sslipj=0.0d0
3747          ssgradlipj=0.0
3748        endif
3749
3750       isubchap=0
3751       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3752       xj_safe=xj
3753       yj_safe=yj
3754       zj_safe=zj
3755       do xshift=-1,1
3756       do yshift=-1,1
3757       do zshift=-1,1
3758           xj=xj_safe+xshift*boxxsize
3759           yj=yj_safe+yshift*boxysize
3760           zj=zj_safe+zshift*boxzsize
3761           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3762           if(dist_temp.lt.dist_init) then
3763             dist_init=dist_temp
3764             xj_temp=xj
3765             yj_temp=yj
3766             zj_temp=zj
3767             isubchap=1
3768           endif
3769        enddo
3770        enddo
3771        enddo
3772        if (isubchap.eq.1) then
3773 !C          print *,i,j
3774           xj=xj_temp-xmedi
3775           yj=yj_temp-ymedi
3776           zj=zj_temp-zmedi
3777        else
3778           xj=xj_safe-xmedi
3779           yj=yj_safe-ymedi
3780           zj=zj_safe-zmedi
3781        endif
3782
3783           rij=xj*xj+yj*yj+zj*zj
3784           rrmij=1.0D0/rij
3785           rij=dsqrt(rij)
3786 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3787             sss_ele_cut=sscale_ele(rij)
3788             sss_ele_grad=sscagrad_ele(rij)
3789 !             sss_ele_cut=1.0d0
3790 !             sss_ele_grad=0.0d0
3791 !            print *,sss_ele_cut,sss_ele_grad,&
3792 !            (rij),r_cut_ele,rlamb_ele
3793 !            if (sss_ele_cut.le.0.0) go to 128
3794
3795           rmij=1.0D0/rij
3796           r3ij=rrmij*rmij
3797           r6ij=r3ij*r3ij
3798           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3799           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3800           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3801           fac=cosa-3.0D0*cosb*cosg
3802           ev1=aaa*r6ij*r6ij
3803 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3804           if (j.eq.i+2) ev1=scal_el*ev1
3805           ev2=bbb*r6ij
3806           fac3=ael6i*r6ij
3807           fac4=ael3i*r3ij
3808           evdwij=ev1+ev2
3809           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3810           el2=fac4*fac
3811 !          eesij=el1+el2
3812           if (shield_mode.gt.0) then
3813 !C          fac_shield(i)=0.4
3814 !C          fac_shield(j)=0.6
3815           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3816           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3817           eesij=(el1+el2)
3818           ees=ees+eesij*sss_ele_cut
3819 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3820 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3821           else
3822           fac_shield(i)=1.0
3823           fac_shield(j)=1.0
3824           eesij=(el1+el2)
3825           ees=ees+eesij   &
3826             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3827 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3828           endif
3829
3830 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3831           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3832 !          ees=ees+eesij*sss_ele_cut
3833           evdw1=evdw1+evdwij*sss_ele_cut  &
3834            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3835 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3836 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3837 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3838 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3839
3840           if (energy_dec) then
3841 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3842 !                  'evdw1',i,j,evdwij,&
3843 !                  iteli,itelj,aaa,evdw1
3844               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3845               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3846           endif
3847 !
3848 ! Calculate contributions to the Cartesian gradient.
3849 !
3850 #ifdef SPLITELE
3851           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3852               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3853           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3854              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3855           fac1=fac
3856           erij(1)=xj*rmij
3857           erij(2)=yj*rmij
3858           erij(3)=zj*rmij
3859 !
3860 ! Radial derivatives. First process both termini of the fragment (i,j)
3861 !
3862           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3863           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3864           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3865            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3866           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3867             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3868
3869           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3870           (shield_mode.gt.0)) then
3871 !C          print *,i,j
3872           do ilist=1,ishield_list(i)
3873            iresshield=shield_list(ilist,i)
3874            do k=1,3
3875            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3876            *2.0*sss_ele_cut
3877            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3878                    rlocshield &
3879             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3880             *sss_ele_cut
3881             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3882            enddo
3883           enddo
3884           do ilist=1,ishield_list(j)
3885            iresshield=shield_list(ilist,j)
3886            do k=1,3
3887            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3888           *2.0*sss_ele_cut
3889            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3890                    rlocshield &
3891            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3892            *sss_ele_cut
3893            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3894            enddo
3895           enddo
3896           do k=1,3
3897             gshieldc(k,i)=gshieldc(k,i)+ &
3898                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3899            *sss_ele_cut
3900
3901             gshieldc(k,j)=gshieldc(k,j)+ &
3902                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3903            *sss_ele_cut
3904
3905             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3906                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3907            *sss_ele_cut
3908
3909             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3910                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3911            *sss_ele_cut
3912
3913            enddo
3914            endif
3915
3916
3917 !          do k=1,3
3918 !            ghalf=0.5D0*ggg(k)
3919 !            gelc(k,i)=gelc(k,i)+ghalf
3920 !            gelc(k,j)=gelc(k,j)+ghalf
3921 !          enddo
3922 ! 9/28/08 AL Gradient compotents will be summed only at the end
3923           do k=1,3
3924             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3925             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3926           enddo
3927             gelc_long(3,j)=gelc_long(3,j)+  &
3928           ssgradlipj*eesij/2.0d0*lipscale**2&
3929            *sss_ele_cut
3930
3931             gelc_long(3,i)=gelc_long(3,i)+  &
3932           ssgradlipi*eesij/2.0d0*lipscale**2&
3933            *sss_ele_cut
3934
3935
3936 !
3937 ! Loop over residues i+1 thru j-1.
3938 !
3939 !grad          do k=i+1,j-1
3940 !grad            do l=1,3
3941 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3942 !grad            enddo
3943 !grad          enddo
3944           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3945            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3946           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3947            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3948           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3949            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3950
3951 !          do k=1,3
3952 !            ghalf=0.5D0*ggg(k)
3953 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3954 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3955 !          enddo
3956 ! 9/28/08 AL Gradient compotents will be summed only at the end
3957           do k=1,3
3958             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3959             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3960           enddo
3961
3962 !C Lipidic part for scaling weight
3963            gvdwpp(3,j)=gvdwpp(3,j)+ &
3964           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3965            gvdwpp(3,i)=gvdwpp(3,i)+ &
3966           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3967 !! Loop over residues i+1 thru j-1.
3968 !
3969 !grad          do k=i+1,j-1
3970 !grad            do l=1,3
3971 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3972 !grad            enddo
3973 !grad          enddo
3974 #else
3975           facvdw=(ev1+evdwij)*sss_ele_cut &
3976            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3977
3978           facel=(el1+eesij)*sss_ele_cut
3979           fac1=fac
3980           fac=-3*rrmij*(facvdw+facvdw+facel)
3981           erij(1)=xj*rmij
3982           erij(2)=yj*rmij
3983           erij(3)=zj*rmij
3984 !
3985 ! Radial derivatives. First process both termini of the fragment (i,j)
3986 !
3987           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3988           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3989           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3990 !          do k=1,3
3991 !            ghalf=0.5D0*ggg(k)
3992 !            gelc(k,i)=gelc(k,i)+ghalf
3993 !            gelc(k,j)=gelc(k,j)+ghalf
3994 !          enddo
3995 ! 9/28/08 AL Gradient compotents will be summed only at the end
3996           do k=1,3
3997             gelc_long(k,j)=gelc(k,j)+ggg(k)
3998             gelc_long(k,i)=gelc(k,i)-ggg(k)
3999           enddo
4000 !
4001 ! Loop over residues i+1 thru j-1.
4002 !
4003 !grad          do k=i+1,j-1
4004 !grad            do l=1,3
4005 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4006 !grad            enddo
4007 !grad          enddo
4008 ! 9/28/08 AL Gradient compotents will be summed only at the end
4009           ggg(1)=facvdw*xj &
4010            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4011           ggg(2)=facvdw*yj &
4012            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4013           ggg(3)=facvdw*zj &
4014            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4015
4016           do k=1,3
4017             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4018             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4019           enddo
4020            gvdwpp(3,j)=gvdwpp(3,j)+ &
4021           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4022            gvdwpp(3,i)=gvdwpp(3,i)+ &
4023           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4024
4025 #endif
4026 !
4027 ! Angular part
4028 !
4029           ecosa=2.0D0*fac3*fac1+fac4
4030           fac4=-3.0D0*fac4
4031           fac3=-6.0D0*fac3
4032           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4033           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4034           do k=1,3
4035             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4036             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4037           enddo
4038 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4039 !d   &          (dcosg(k),k=1,3)
4040           do k=1,3
4041             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4042              *fac_shield(i)**2*fac_shield(j)**2 &
4043              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4044
4045           enddo
4046 !          do k=1,3
4047 !            ghalf=0.5D0*ggg(k)
4048 !            gelc(k,i)=gelc(k,i)+ghalf
4049 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4050 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4051 !            gelc(k,j)=gelc(k,j)+ghalf
4052 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4053 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4054 !          enddo
4055 !grad          do k=i+1,j-1
4056 !grad            do l=1,3
4057 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4058 !grad            enddo
4059 !grad          enddo
4060           do k=1,3
4061             gelc(k,i)=gelc(k,i) &
4062                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4063                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4064                      *sss_ele_cut &
4065                      *fac_shield(i)**2*fac_shield(j)**2 &
4066                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4067
4068             gelc(k,j)=gelc(k,j) &
4069                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4070                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+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_long(k,j)=gelc_long(k,j)+ggg(k)
4076             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4077           enddo
4078
4079           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4080               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4081               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4082 !
4083 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4084 !   energy of a peptide unit is assumed in the form of a second-order
4085 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4086 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4087 !   are computed for EVERY pair of non-contiguous peptide groups.
4088 !
4089           if (j.lt.nres-1) then
4090             j1=j+1
4091             j2=j-1
4092           else
4093             j1=j-1
4094             j2=j-2
4095           endif
4096           kkk=0
4097           do k=1,2
4098             do l=1,2
4099               kkk=kkk+1
4100               muij(kkk)=mu(k,i)*mu(l,j)
4101 #ifdef NEWCORR
4102              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4103 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4104              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4105              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4106 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4107              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4108 #endif
4109
4110             enddo
4111           enddo
4112 !d         write (iout,*) 'EELEC: i',i,' j',j
4113 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4114 !d          write(iout,*) 'muij',muij
4115           ury=scalar(uy(1,i),erij)
4116           urz=scalar(uz(1,i),erij)
4117           vry=scalar(uy(1,j),erij)
4118           vrz=scalar(uz(1,j),erij)
4119           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4120           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4121           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4122           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4123           fac=dsqrt(-ael6i)*r3ij
4124           a22=a22*fac
4125           a23=a23*fac
4126           a32=a32*fac
4127           a33=a33*fac
4128 !d          write (iout,'(4i5,4f10.5)')
4129 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4130 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4131 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4132 !d     &      uy(:,j),uz(:,j)
4133 !d          write (iout,'(4f10.5)')
4134 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4135 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4136 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4137 !d           write (iout,'(9f10.5/)')
4138 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4139 ! Derivatives of the elements of A in virtual-bond vectors
4140           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4141           do k=1,3
4142             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4143             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4144             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4145             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4146             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4147             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4148             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4149             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4150             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4151             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4152             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4153             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4154           enddo
4155 ! Compute radial contributions to the gradient
4156           facr=-3.0d0*rrmij
4157           a22der=a22*facr
4158           a23der=a23*facr
4159           a32der=a32*facr
4160           a33der=a33*facr
4161           agg(1,1)=a22der*xj
4162           agg(2,1)=a22der*yj
4163           agg(3,1)=a22der*zj
4164           agg(1,2)=a23der*xj
4165           agg(2,2)=a23der*yj
4166           agg(3,2)=a23der*zj
4167           agg(1,3)=a32der*xj
4168           agg(2,3)=a32der*yj
4169           agg(3,3)=a32der*zj
4170           agg(1,4)=a33der*xj
4171           agg(2,4)=a33der*yj
4172           agg(3,4)=a33der*zj
4173 ! Add the contributions coming from er
4174           fac3=-3.0d0*fac
4175           do k=1,3
4176             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4177             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4178             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4179             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4180           enddo
4181           do k=1,3
4182 ! Derivatives in DC(i)
4183 !grad            ghalf1=0.5d0*agg(k,1)
4184 !grad            ghalf2=0.5d0*agg(k,2)
4185 !grad            ghalf3=0.5d0*agg(k,3)
4186 !grad            ghalf4=0.5d0*agg(k,4)
4187             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4188             -3.0d0*uryg(k,2)*vry)!+ghalf1
4189             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4190             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4191             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4192             -3.0d0*urzg(k,2)*vry)!+ghalf3
4193             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4194             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4195 ! Derivatives in DC(i+1)
4196             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4197             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4198             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4199             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4200             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4201             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4202             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4203             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4204 ! Derivatives in DC(j)
4205             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4206             -3.0d0*vryg(k,2)*ury)!+ghalf1
4207             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4208             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4209             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4210             -3.0d0*vryg(k,2)*urz)!+ghalf3
4211             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4212             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4213 ! Derivatives in DC(j+1) or DC(nres-1)
4214             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4215             -3.0d0*vryg(k,3)*ury)
4216             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4217             -3.0d0*vrzg(k,3)*ury)
4218             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4219             -3.0d0*vryg(k,3)*urz)
4220             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4221             -3.0d0*vrzg(k,3)*urz)
4222 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4223 !grad              do l=1,4
4224 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4225 !grad              enddo
4226 !grad            endif
4227           enddo
4228           acipa(1,1)=a22
4229           acipa(1,2)=a23
4230           acipa(2,1)=a32
4231           acipa(2,2)=a33
4232           a22=-a22
4233           a23=-a23
4234           do l=1,2
4235             do k=1,3
4236               agg(k,l)=-agg(k,l)
4237               aggi(k,l)=-aggi(k,l)
4238               aggi1(k,l)=-aggi1(k,l)
4239               aggj(k,l)=-aggj(k,l)
4240               aggj1(k,l)=-aggj1(k,l)
4241             enddo
4242           enddo
4243           if (j.lt.nres-1) then
4244             a22=-a22
4245             a32=-a32
4246             do l=1,3,2
4247               do k=1,3
4248                 agg(k,l)=-agg(k,l)
4249                 aggi(k,l)=-aggi(k,l)
4250                 aggi1(k,l)=-aggi1(k,l)
4251                 aggj(k,l)=-aggj(k,l)
4252                 aggj1(k,l)=-aggj1(k,l)
4253               enddo
4254             enddo
4255           else
4256             a22=-a22
4257             a23=-a23
4258             a32=-a32
4259             a33=-a33
4260             do l=1,4
4261               do k=1,3
4262                 agg(k,l)=-agg(k,l)
4263                 aggi(k,l)=-aggi(k,l)
4264                 aggi1(k,l)=-aggi1(k,l)
4265                 aggj(k,l)=-aggj(k,l)
4266                 aggj1(k,l)=-aggj1(k,l)
4267               enddo
4268             enddo
4269           endif
4270           ENDIF ! WCORR
4271           IF (wel_loc.gt.0.0d0) THEN
4272 ! Contribution to the local-electrostatic energy coming from the i-j pair
4273           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4274            +a33*muij(4)
4275           if (shield_mode.eq.0) then
4276            fac_shield(i)=1.0
4277            fac_shield(j)=1.0
4278           endif
4279           eel_loc_ij=eel_loc_ij &
4280          *fac_shield(i)*fac_shield(j) &
4281          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4282 !C Now derivative over eel_loc
4283           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4284          (shield_mode.gt.0)) then
4285 !C          print *,i,j
4286
4287           do ilist=1,ishield_list(i)
4288            iresshield=shield_list(ilist,i)
4289            do k=1,3
4290            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4291                                                 /fac_shield(i)&
4292            *sss_ele_cut
4293            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4294                    rlocshield  &
4295           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4296           *sss_ele_cut
4297
4298             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4299            +rlocshield
4300            enddo
4301           enddo
4302           do ilist=1,ishield_list(j)
4303            iresshield=shield_list(ilist,j)
4304            do k=1,3
4305            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4306                                             /fac_shield(j)   &
4307             *sss_ele_cut
4308            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4309                    rlocshield  &
4310       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4311        *sss_ele_cut
4312
4313            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4314                   +rlocshield
4315
4316            enddo
4317           enddo
4318
4319           do k=1,3
4320             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4321                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4322                     *sss_ele_cut
4323             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4324                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4325                     *sss_ele_cut
4326             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4327                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4328                     *sss_ele_cut
4329             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4330                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4331                     *sss_ele_cut
4332
4333            enddo
4334            endif
4335
4336 #ifdef NEWCORR
4337          geel_loc_ij=(a22*gmuij1(1)&
4338           +a23*gmuij1(2)&
4339           +a32*gmuij1(3)&
4340           +a33*gmuij1(4))&
4341          *fac_shield(i)*fac_shield(j)
4342 !c         write(iout,*) "derivative over thatai"
4343 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4344 !c     &   a33*gmuij1(4)
4345          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4346            geel_loc_ij*wel_loc
4347 !c         write(iout,*) "derivative over thatai-1"
4348 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4349 !c     &   a33*gmuij2(4)
4350          geel_loc_ij=&
4351           a22*gmuij2(1)&
4352           +a23*gmuij2(2)&
4353           +a32*gmuij2(3)&
4354           +a33*gmuij2(4)
4355          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4356            geel_loc_ij*wel_loc&
4357          *fac_shield(i)*fac_shield(j)
4358
4359 !c  Derivative over j residue
4360          geel_loc_ji=a22*gmuji1(1)&
4361           +a23*gmuji1(2)&
4362           +a32*gmuji1(3)&
4363           +a33*gmuji1(4)
4364 !c         write(iout,*) "derivative over thataj"
4365 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4366 !c     &   a33*gmuji1(4)
4367
4368         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4369            geel_loc_ji*wel_loc&
4370          *fac_shield(i)*fac_shield(j)
4371
4372          geel_loc_ji=&
4373           +a22*gmuji2(1)&
4374           +a23*gmuji2(2)&
4375           +a32*gmuji2(3)&
4376           +a33*gmuji2(4)
4377 !c         write(iout,*) "derivative over thataj-1"
4378 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4379 !c     &   a33*gmuji2(4)
4380          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4381            geel_loc_ji*wel_loc&
4382          *fac_shield(i)*fac_shield(j)
4383 #endif
4384
4385 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4386 !           eel_loc_ij=0.0
4387 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4388 !                  'eelloc',i,j,eel_loc_ij
4389           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4390                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4391 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4392
4393 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4394 !          if (energy_dec) write (iout,*) "muij",muij
4395 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4396
4397           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4398 ! Partial derivatives in virtual-bond dihedral angles gamma
4399           if (i.gt.1) &
4400           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4401                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4402                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4403                  *sss_ele_cut  &
4404           *fac_shield(i)*fac_shield(j) &
4405           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4406
4407           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4408                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4409                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4410                  *sss_ele_cut &
4411           *fac_shield(i)*fac_shield(j) &
4412           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4413 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4414 !          do l=1,3
4415 !            ggg(1)=(agg(1,1)*muij(1)+ &
4416 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4417 !            *sss_ele_cut &
4418 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4419 !            ggg(2)=(agg(2,1)*muij(1)+ &
4420 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4421 !            *sss_ele_cut &
4422 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4423 !            ggg(3)=(agg(3,1)*muij(1)+ &
4424 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4425 !            *sss_ele_cut &
4426 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4427            xtemp(1)=xj
4428            xtemp(2)=yj
4429            xtemp(3)=zj
4430
4431            do l=1,3
4432             ggg(l)=(agg(l,1)*muij(1)+ &
4433                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4434             *sss_ele_cut &
4435           *fac_shield(i)*fac_shield(j) &
4436           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4437              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4438
4439
4440             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4441             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4442 !grad            ghalf=0.5d0*ggg(l)
4443 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4444 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4445           enddo
4446             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4447           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4448           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4449
4450             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4451           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4452           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4453
4454 !grad          do k=i+1,j2
4455 !grad            do l=1,3
4456 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4457 !grad            enddo
4458 !grad          enddo
4459 ! Remaining derivatives of eello
4460           do l=1,3
4461             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4462                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4463             *sss_ele_cut &
4464           *fac_shield(i)*fac_shield(j) &
4465           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4466
4467 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4468             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4469                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4470             +aggi1(l,4)*muij(4))&
4471             *sss_ele_cut &
4472           *fac_shield(i)*fac_shield(j) &
4473           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4474
4475 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4476             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4477                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4478             *sss_ele_cut &
4479           *fac_shield(i)*fac_shield(j) &
4480           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4481
4482 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4483             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4484                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4485             +aggj1(l,4)*muij(4))&
4486             *sss_ele_cut &
4487           *fac_shield(i)*fac_shield(j) &
4488          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4489
4490 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4491           enddo
4492           ENDIF
4493 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4494 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4495           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4496              .and. num_conti.le.maxconts) then
4497 !            write (iout,*) i,j," entered corr"
4498 !
4499 ! Calculate the contact function. The ith column of the array JCONT will
4500 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4501 ! greater than I). The arrays FACONT and GACONT will contain the values of
4502 ! the contact function and its derivative.
4503 !           r0ij=1.02D0*rpp(iteli,itelj)
4504 !           r0ij=1.11D0*rpp(iteli,itelj)
4505             r0ij=2.20D0*rpp(iteli,itelj)
4506 !           r0ij=1.55D0*rpp(iteli,itelj)
4507             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4508 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4509             if (fcont.gt.0.0D0) then
4510               num_conti=num_conti+1
4511               if (num_conti.gt.maxconts) then
4512 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4513 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4514                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4515                                ' will skip next contacts for this conf.', num_conti
4516               else
4517                 jcont_hb(num_conti,i)=j
4518 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4519 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4520                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4521                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4522 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4523 !  terms.
4524                 d_cont(num_conti,i)=rij
4525 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4526 !     --- Electrostatic-interaction matrix ---
4527                 a_chuj(1,1,num_conti,i)=a22
4528                 a_chuj(1,2,num_conti,i)=a23
4529                 a_chuj(2,1,num_conti,i)=a32
4530                 a_chuj(2,2,num_conti,i)=a33
4531 !     --- Gradient of rij
4532                 do kkk=1,3
4533                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4534                 enddo
4535                 kkll=0
4536                 do k=1,2
4537                   do l=1,2
4538                     kkll=kkll+1
4539                     do m=1,3
4540                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4541                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4542                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4543                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4544                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4545                     enddo
4546                   enddo
4547                 enddo
4548                 ENDIF
4549                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4550 ! Calculate contact energies
4551                 cosa4=4.0D0*cosa
4552                 wij=cosa-3.0D0*cosb*cosg
4553                 cosbg1=cosb+cosg
4554                 cosbg2=cosb-cosg
4555 !               fac3=dsqrt(-ael6i)/r0ij**3
4556                 fac3=dsqrt(-ael6i)*r3ij
4557 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4558                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4559                 if (ees0tmp.gt.0) then
4560                   ees0pij=dsqrt(ees0tmp)
4561                 else
4562                   ees0pij=0
4563                 endif
4564                 if (shield_mode.eq.0) then
4565                 fac_shield(i)=1.0d0
4566                 fac_shield(j)=1.0d0
4567                 else
4568                 ees0plist(num_conti,i)=j
4569                 endif
4570 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4571                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4572                 if (ees0tmp.gt.0) then
4573                   ees0mij=dsqrt(ees0tmp)
4574                 else
4575                   ees0mij=0
4576                 endif
4577 !               ees0mij=0.0D0
4578                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4579                      *sss_ele_cut &
4580                      *fac_shield(i)*fac_shield(j)
4581
4582                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4583                      *sss_ele_cut &
4584                      *fac_shield(i)*fac_shield(j)
4585
4586 ! Diagnostics. Comment out or remove after debugging!
4587 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4588 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4589 !               ees0m(num_conti,i)=0.0D0
4590 ! End diagnostics.
4591 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4592 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4593 ! Angular derivatives of the contact function
4594                 ees0pij1=fac3/ees0pij
4595                 ees0mij1=fac3/ees0mij
4596                 fac3p=-3.0D0*fac3*rrmij
4597                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4598                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4599 !               ees0mij1=0.0D0
4600                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4601                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4602                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4603                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4604                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4605                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4606                 ecosap=ecosa1+ecosa2
4607                 ecosbp=ecosb1+ecosb2
4608                 ecosgp=ecosg1+ecosg2
4609                 ecosam=ecosa1-ecosa2
4610                 ecosbm=ecosb1-ecosb2
4611                 ecosgm=ecosg1-ecosg2
4612 ! Diagnostics
4613 !               ecosap=ecosa1
4614 !               ecosbp=ecosb1
4615 !               ecosgp=ecosg1
4616 !               ecosam=0.0D0
4617 !               ecosbm=0.0D0
4618 !               ecosgm=0.0D0
4619 ! End diagnostics
4620                 facont_hb(num_conti,i)=fcont
4621                 fprimcont=fprimcont/rij
4622 !d              facont_hb(num_conti,i)=1.0D0
4623 ! Following line is for diagnostics.
4624 !d              fprimcont=0.0D0
4625                 do k=1,3
4626                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4627                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4628                 enddo
4629                 do k=1,3
4630                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4631                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4632                 enddo
4633                 gggp(1)=gggp(1)+ees0pijp*xj &
4634                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4635                 gggp(2)=gggp(2)+ees0pijp*yj &
4636                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4637                 gggp(3)=gggp(3)+ees0pijp*zj &
4638                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4639
4640                 gggm(1)=gggm(1)+ees0mijp*xj &
4641                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4642
4643                 gggm(2)=gggm(2)+ees0mijp*yj &
4644                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4645
4646                 gggm(3)=gggm(3)+ees0mijp*zj &
4647                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4648
4649 ! Derivatives due to the contact function
4650                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4651                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4652                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4653                 do k=1,3
4654 !
4655 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4656 !          following the change of gradient-summation algorithm.
4657 !
4658 !grad                  ghalfp=0.5D0*gggp(k)
4659 !grad                  ghalfm=0.5D0*gggm(k)
4660                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4661                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4662                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4663                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4664
4665                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4666                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4667                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4668                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4669
4670                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4671                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4672
4673                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4674                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4675                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4676                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4677
4678                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4679                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4680                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4681                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4682
4683                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4684                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4685
4686                 enddo
4687 ! Diagnostics. Comment out or remove after debugging!
4688 !diag           do k=1,3
4689 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4690 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4691 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4692 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4693 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4694 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4695 !diag           enddo
4696               ENDIF ! wcorr
4697               endif  ! num_conti.le.maxconts
4698             endif  ! fcont.gt.0
4699           endif    ! j.gt.i+1
4700           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4701             do k=1,4
4702               do l=1,3
4703                 ghalf=0.5d0*agg(l,k)
4704                 aggi(l,k)=aggi(l,k)+ghalf
4705                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4706                 aggj(l,k)=aggj(l,k)+ghalf
4707               enddo
4708             enddo
4709             if (j.eq.nres-1 .and. i.lt.j-2) then
4710               do k=1,4
4711                 do l=1,3
4712                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4713                 enddo
4714               enddo
4715             endif
4716           endif
4717  128  continue
4718 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4719       return
4720       end subroutine eelecij
4721 !-----------------------------------------------------------------------------
4722       subroutine eturn3(i,eello_turn3)
4723 ! Third- and fourth-order contributions from turns
4724
4725       use comm_locel
4726 !      implicit real*8 (a-h,o-z)
4727 !      include 'DIMENSIONS'
4728 !      include 'COMMON.IOUNITS'
4729 !      include 'COMMON.GEO'
4730 !      include 'COMMON.VAR'
4731 !      include 'COMMON.LOCAL'
4732 !      include 'COMMON.CHAIN'
4733 !      include 'COMMON.DERIV'
4734 !      include 'COMMON.INTERACT'
4735 !      include 'COMMON.CONTACTS'
4736 !      include 'COMMON.TORSION'
4737 !      include 'COMMON.VECTORS'
4738 !      include 'COMMON.FFIELD'
4739 !      include 'COMMON.CONTROL'
4740       real(kind=8),dimension(3) :: ggg
4741       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4742         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4743        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4744
4745       real(kind=8),dimension(2) :: auxvec,auxvec1
4746 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4747       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4748 !el      integer :: num_conti,j1,j2
4749 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4750 !el        dz_normi,xmedi,ymedi,zmedi
4751
4752 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4753 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4754 !el         num_conti,j1,j2
4755 !el local variables
4756       integer :: i,j,l,k,ilist,iresshield
4757       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4758
4759       j=i+2
4760 !      write (iout,*) "eturn3",i,j,j1,j2
4761           zj=(c(3,j)+c(3,j+1))/2.0d0
4762           zj=mod(zj,boxzsize)
4763           if (zj.lt.0) zj=zj+boxzsize
4764           if ((zj.lt.0)) write (*,*) "CHUJ"
4765        if ((zj.gt.bordlipbot)  &
4766         .and.(zj.lt.bordliptop)) then
4767 !C the energy transfer exist
4768         if (zj.lt.buflipbot) then
4769 !C what fraction I am in
4770          fracinbuf=1.0d0-     &
4771              ((zj-bordlipbot)/lipbufthick)
4772 !C lipbufthick is thickenes of lipid buffore
4773          sslipj=sscalelip(fracinbuf)
4774          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4775         elseif (zj.gt.bufliptop) then
4776          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4777          sslipj=sscalelip(fracinbuf)
4778          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4779         else
4780          sslipj=1.0d0
4781          ssgradlipj=0.0
4782         endif
4783        else
4784          sslipj=0.0d0
4785          ssgradlipj=0.0
4786        endif
4787
4788       a_temp(1,1)=a22
4789       a_temp(1,2)=a23
4790       a_temp(2,1)=a32
4791       a_temp(2,2)=a33
4792 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4793 !
4794 !               Third-order contributions
4795 !
4796 !                 (i+2)o----(i+3)
4797 !                      | |
4798 !                      | |
4799 !                 (i+1)o----i
4800 !
4801 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4802 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4803         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4804         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4805         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4806         call transpose2(auxmat(1,1),auxmat1(1,1))
4807         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4808         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4809         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4810         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4811         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4812
4813         if (shield_mode.eq.0) then
4814         fac_shield(i)=1.0d0
4815         fac_shield(j)=1.0d0
4816         endif
4817
4818         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4819          *fac_shield(i)*fac_shield(j)  &
4820          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4821         eello_t3= &
4822         0.5d0*(pizda(1,1)+pizda(2,2)) &
4823         *fac_shield(i)*fac_shield(j)
4824
4825         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4826                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4827 !C#ifdef NEWCORR
4828 !C Derivatives in theta
4829         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4830        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4831         *fac_shield(i)*fac_shield(j)
4832         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4833        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4834         *fac_shield(i)*fac_shield(j)
4835 !C#endif
4836
4837
4838
4839           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4840        (shield_mode.gt.0)) then
4841 !C          print *,i,j
4842
4843           do ilist=1,ishield_list(i)
4844            iresshield=shield_list(ilist,i)
4845            do k=1,3
4846            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4847            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4848                    rlocshield &
4849            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4850             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4851              +rlocshield
4852            enddo
4853           enddo
4854           do ilist=1,ishield_list(j)
4855            iresshield=shield_list(ilist,j)
4856            do k=1,3
4857            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4858            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4859                    rlocshield &
4860            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4861            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4862                   +rlocshield
4863
4864            enddo
4865           enddo
4866
4867           do k=1,3
4868             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4869                    grad_shield(k,i)*eello_t3/fac_shield(i)
4870             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4871                    grad_shield(k,j)*eello_t3/fac_shield(j)
4872             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4873                    grad_shield(k,i)*eello_t3/fac_shield(i)
4874             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4875                    grad_shield(k,j)*eello_t3/fac_shield(j)
4876            enddo
4877            endif
4878
4879 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4880 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4881 !d     &    ' eello_turn3_num',4*eello_turn3_num
4882 ! Derivatives in gamma(i)
4883         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4884         call transpose2(auxmat2(1,1),auxmat3(1,1))
4885         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4886         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4887           *fac_shield(i)*fac_shield(j)        &
4888           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4889 ! Derivatives in gamma(i+1)
4890         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4891         call transpose2(auxmat2(1,1),auxmat3(1,1))
4892         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4893         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4894           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4895           *fac_shield(i)*fac_shield(j)        &
4896           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4897
4898 ! Cartesian derivatives
4899         do l=1,3
4900 !            ghalf1=0.5d0*agg(l,1)
4901 !            ghalf2=0.5d0*agg(l,2)
4902 !            ghalf3=0.5d0*agg(l,3)
4903 !            ghalf4=0.5d0*agg(l,4)
4904           a_temp(1,1)=aggi(l,1)!+ghalf1
4905           a_temp(1,2)=aggi(l,2)!+ghalf2
4906           a_temp(2,1)=aggi(l,3)!+ghalf3
4907           a_temp(2,2)=aggi(l,4)!+ghalf4
4908           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4909           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4910             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4911           *fac_shield(i)*fac_shield(j)      &
4912           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4913
4914           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4915           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4916           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4917           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4918           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4919           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4920             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4921           *fac_shield(i)*fac_shield(j)        &
4922           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4923
4924           a_temp(1,1)=aggj(l,1)!+ghalf1
4925           a_temp(1,2)=aggj(l,2)!+ghalf2
4926           a_temp(2,1)=aggj(l,3)!+ghalf3
4927           a_temp(2,2)=aggj(l,4)!+ghalf4
4928           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4929           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4930             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4931           *fac_shield(i)*fac_shield(j)      &
4932           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4933
4934           a_temp(1,1)=aggj1(l,1)
4935           a_temp(1,2)=aggj1(l,2)
4936           a_temp(2,1)=aggj1(l,3)
4937           a_temp(2,2)=aggj1(l,4)
4938           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4939           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4940             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4941           *fac_shield(i)*fac_shield(j)        &
4942           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4943         enddo
4944          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4945           ssgradlipi*eello_t3/4.0d0*lipscale
4946          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4947           ssgradlipj*eello_t3/4.0d0*lipscale
4948          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4949           ssgradlipi*eello_t3/4.0d0*lipscale
4950          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4951           ssgradlipj*eello_t3/4.0d0*lipscale
4952
4953       return
4954       end subroutine eturn3
4955 !-----------------------------------------------------------------------------
4956       subroutine eturn4(i,eello_turn4)
4957 ! Third- and fourth-order contributions from turns
4958
4959       use comm_locel
4960 !      implicit real*8 (a-h,o-z)
4961 !      include 'DIMENSIONS'
4962 !      include 'COMMON.IOUNITS'
4963 !      include 'COMMON.GEO'
4964 !      include 'COMMON.VAR'
4965 !      include 'COMMON.LOCAL'
4966 !      include 'COMMON.CHAIN'
4967 !      include 'COMMON.DERIV'
4968 !      include 'COMMON.INTERACT'
4969 !      include 'COMMON.CONTACTS'
4970 !      include 'COMMON.TORSION'
4971 !      include 'COMMON.VECTORS'
4972 !      include 'COMMON.FFIELD'
4973 !      include 'COMMON.CONTROL'
4974       real(kind=8),dimension(3) :: ggg
4975       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4976         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4977         gte1t,gte2t,gte3t,&
4978         gte1a,gtae3,gtae3e2, ae3gte2,&
4979         gtEpizda1,gtEpizda2,gtEpizda3
4980
4981       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4982        auxgEvec3,auxgvec
4983
4984 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4985       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4986 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4987 !el        dz_normi,xmedi,ymedi,zmedi
4988 !el      integer :: num_conti,j1,j2
4989 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4990 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4991 !el          num_conti,j1,j2
4992 !el local variables
4993       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4994       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4995          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
4996
4997       j=i+3
4998 !      if (j.ne.20) return
4999 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5000 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5001 !
5002 !               Fourth-order contributions
5003 !
5004 !                 (i+3)o----(i+4)
5005 !                     /  |
5006 !               (i+2)o   |
5007 !                     \  |
5008 !                 (i+1)o----i
5009 !
5010 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5011 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5012 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5013           zj=(c(3,j)+c(3,j+1))/2.0d0
5014           zj=mod(zj,boxzsize)
5015           if (zj.lt.0) zj=zj+boxzsize
5016        if ((zj.gt.bordlipbot)  &
5017         .and.(zj.lt.bordliptop)) then
5018 !C the energy transfer exist
5019         if (zj.lt.buflipbot) then
5020 !C what fraction I am in
5021          fracinbuf=1.0d0-     &
5022              ((zj-bordlipbot)/lipbufthick)
5023 !C lipbufthick is thickenes of lipid buffore
5024          sslipj=sscalelip(fracinbuf)
5025          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5026         elseif (zj.gt.bufliptop) then
5027          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5028          sslipj=sscalelip(fracinbuf)
5029          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5030         else
5031          sslipj=1.0d0
5032          ssgradlipj=0.0
5033         endif
5034        else
5035          sslipj=0.0d0
5036          ssgradlipj=0.0
5037        endif
5038
5039         a_temp(1,1)=a22
5040         a_temp(1,2)=a23
5041         a_temp(2,1)=a32
5042         a_temp(2,2)=a33
5043         iti1=itortyp(itype(i+1,1))
5044         iti2=itortyp(itype(i+2,1))
5045         iti3=itortyp(itype(i+3,1))
5046 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5047         call transpose2(EUg(1,1,i+1),e1t(1,1))
5048         call transpose2(Eug(1,1,i+2),e2t(1,1))
5049         call transpose2(Eug(1,1,i+3),e3t(1,1))
5050 !C Ematrix derivative in theta
5051         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5052         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5053         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5054
5055         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5056         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5057         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5058         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5059 !c       auxalary matrix of E i+1
5060         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5061         s1=scalar2(b1(1,iti2),auxvec(1))
5062 !c derivative of theta i+2 with constant i+3
5063         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5064 !c derivative of theta i+2 with constant i+2
5065         gs32=scalar2(b1(1,i+2),auxgvec(1))
5066 !c derivative of E matix in theta of i+1
5067         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5068
5069         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5070         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5071         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5072 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5073         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5074 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5075         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5076         s2=scalar2(b1(1,iti1),auxvec(1))
5077 !c derivative of theta i+1 with constant i+3
5078         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5079 !c derivative of theta i+2 with constant i+1
5080         gs21=scalar2(b1(1,i+1),auxgvec(1))
5081 !c derivative of theta i+3 with constant i+1
5082         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5083
5084         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5085         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5086 !c ae3gte2 is derivative over i+2
5087         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5088
5089         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5090         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5091 !c i+2
5092         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5093 !c i+3
5094         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5095
5096         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5097         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5098         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5099         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5100         if (shield_mode.eq.0) then
5101         fac_shield(i)=1.0
5102         fac_shield(j)=1.0
5103         endif
5104
5105         eello_turn4=eello_turn4-(s1+s2+s3) &
5106         *fac_shield(i)*fac_shield(j)       &
5107         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5108         eello_t4=-(s1+s2+s3)  &
5109           *fac_shield(i)*fac_shield(j)
5110 !C Now derivative over shield:
5111           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5112          (shield_mode.gt.0)) then
5113 !C          print *,i,j
5114
5115           do ilist=1,ishield_list(i)
5116            iresshield=shield_list(ilist,i)
5117            do k=1,3
5118            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5119 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5120            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5121                    rlocshield &
5122             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5123             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5124            +rlocshield
5125            enddo
5126           enddo
5127           do ilist=1,ishield_list(j)
5128            iresshield=shield_list(ilist,j)
5129            do k=1,3
5130 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5131            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5132            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5133                    rlocshield  &
5134            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5135            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5136                   +rlocshield
5137 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5138
5139            enddo
5140           enddo
5141           do k=1,3
5142             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5143                    grad_shield(k,i)*eello_t4/fac_shield(i)
5144             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5145                    grad_shield(k,j)*eello_t4/fac_shield(j)
5146             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5147                    grad_shield(k,i)*eello_t4/fac_shield(i)
5148             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5149                    grad_shield(k,j)*eello_t4/fac_shield(j)
5150 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5151            enddo
5152            endif
5153 #ifdef NEWCORR
5154         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5155                        -(gs13+gsE13+gsEE1)*wturn4&
5156        *fac_shield(i)*fac_shield(j)
5157         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5158                          -(gs23+gs21+gsEE2)*wturn4&
5159        *fac_shield(i)*fac_shield(j)
5160
5161         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5162                          -(gs32+gsE31+gsEE3)*wturn4&
5163        *fac_shield(i)*fac_shield(j)
5164
5165 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5166 !c     &   gs2
5167 #endif
5168         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5169            'eturn4',i,j,-(s1+s2+s3)
5170 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5171 !d     &    ' eello_turn4_num',8*eello_turn4_num
5172 ! Derivatives in gamma(i)
5173         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5174         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5175         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5176         s1=scalar2(b1(1,iti2),auxvec(1))
5177         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5178         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5179         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5180        *fac_shield(i)*fac_shield(j)  &
5181        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5182
5183 ! Derivatives in gamma(i+1)
5184         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5185         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5186         s2=scalar2(b1(1,iti1),auxvec(1))
5187         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5188         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5189         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5190         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5191        *fac_shield(i)*fac_shield(j)  &
5192        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5193
5194 ! Derivatives in gamma(i+2)
5195         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5196         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5197         s1=scalar2(b1(1,iti2),auxvec(1))
5198         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5199         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5200         s2=scalar2(b1(1,iti1),auxvec(1))
5201         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5202         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5203         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5204         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5205        *fac_shield(i)*fac_shield(j)  &
5206        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5207
5208 ! Cartesian derivatives
5209 ! Derivatives of this turn contributions in DC(i+2)
5210         if (j.lt.nres-1) then
5211           do l=1,3
5212             a_temp(1,1)=agg(l,1)
5213             a_temp(1,2)=agg(l,2)
5214             a_temp(2,1)=agg(l,3)
5215             a_temp(2,2)=agg(l,4)
5216             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5217             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5218             s1=scalar2(b1(1,iti2),auxvec(1))
5219             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5220             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5221             s2=scalar2(b1(1,iti1),auxvec(1))
5222             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5223             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5224             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5225             ggg(l)=-(s1+s2+s3)
5226             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5227        *fac_shield(i)*fac_shield(j)  &
5228        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5229
5230           enddo
5231         endif
5232 ! Remaining derivatives of this turn contribution
5233         do l=1,3
5234           a_temp(1,1)=aggi(l,1)
5235           a_temp(1,2)=aggi(l,2)
5236           a_temp(2,1)=aggi(l,3)
5237           a_temp(2,2)=aggi(l,4)
5238           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5239           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5240           s1=scalar2(b1(1,iti2),auxvec(1))
5241           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5242           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5243           s2=scalar2(b1(1,iti1),auxvec(1))
5244           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5245           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5246           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5247           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5248          *fac_shield(i)*fac_shield(j)  &
5249          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5250
5251
5252           a_temp(1,1)=aggi1(l,1)
5253           a_temp(1,2)=aggi1(l,2)
5254           a_temp(2,1)=aggi1(l,3)
5255           a_temp(2,2)=aggi1(l,4)
5256           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5257           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5258           s1=scalar2(b1(1,iti2),auxvec(1))
5259           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5260           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5261           s2=scalar2(b1(1,iti1),auxvec(1))
5262           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5263           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5264           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5265           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5266          *fac_shield(i)*fac_shield(j)  &
5267          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5268
5269
5270           a_temp(1,1)=aggj(l,1)
5271           a_temp(1,2)=aggj(l,2)
5272           a_temp(2,1)=aggj(l,3)
5273           a_temp(2,2)=aggj(l,4)
5274           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5275           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5276           s1=scalar2(b1(1,iti2),auxvec(1))
5277           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5278           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5279           s2=scalar2(b1(1,iti1),auxvec(1))
5280           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5281           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5282           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5283 !        if (j.lt.nres-1) then
5284           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5285          *fac_shield(i)*fac_shield(j)  &
5286          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5287 !        endif
5288
5289           a_temp(1,1)=aggj1(l,1)
5290           a_temp(1,2)=aggj1(l,2)
5291           a_temp(2,1)=aggj1(l,3)
5292           a_temp(2,2)=aggj1(l,4)
5293           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5294           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5295           s1=scalar2(b1(1,iti2),auxvec(1))
5296           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5297           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5298           s2=scalar2(b1(1,iti1),auxvec(1))
5299           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5300           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5301           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5302 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5303 !        if (j.lt.nres-1) then
5304 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5305           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5306          *fac_shield(i)*fac_shield(j)  &
5307          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5308 !            if (shield_mode.gt.0) then
5309 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5310 !            else
5311 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5312 !            endif
5313 !         endif
5314         enddo
5315          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5316           ssgradlipi*eello_t4/4.0d0*lipscale
5317          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5318           ssgradlipj*eello_t4/4.0d0*lipscale
5319          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5320           ssgradlipi*eello_t4/4.0d0*lipscale
5321          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5322           ssgradlipj*eello_t4/4.0d0*lipscale
5323
5324       return
5325       end subroutine eturn4
5326 !-----------------------------------------------------------------------------
5327       subroutine unormderiv(u,ugrad,unorm,ungrad)
5328 ! This subroutine computes the derivatives of a normalized vector u, given
5329 ! the derivatives computed without normalization conditions, ugrad. Returns
5330 ! ungrad.
5331 !      implicit none
5332       real(kind=8),dimension(3) :: u,vec
5333       real(kind=8),dimension(3,3) ::ugrad,ungrad
5334       real(kind=8) :: unorm      !,scalar
5335       integer :: i,j
5336 !      write (2,*) 'ugrad',ugrad
5337 !      write (2,*) 'u',u
5338       do i=1,3
5339         vec(i)=scalar(ugrad(1,i),u(1))
5340       enddo
5341 !      write (2,*) 'vec',vec
5342       do i=1,3
5343         do j=1,3
5344           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5345         enddo
5346       enddo
5347 !      write (2,*) 'ungrad',ungrad
5348       return
5349       end subroutine unormderiv
5350 !-----------------------------------------------------------------------------
5351       subroutine escp_soft_sphere(evdw2,evdw2_14)
5352 !
5353 ! This subroutine calculates the excluded-volume interaction energy between
5354 ! peptide-group centers and side chains and its gradient in virtual-bond and
5355 ! side-chain vectors.
5356 !
5357 !      implicit real*8 (a-h,o-z)
5358 !      include 'DIMENSIONS'
5359 !      include 'COMMON.GEO'
5360 !      include 'COMMON.VAR'
5361 !      include 'COMMON.LOCAL'
5362 !      include 'COMMON.CHAIN'
5363 !      include 'COMMON.DERIV'
5364 !      include 'COMMON.INTERACT'
5365 !      include 'COMMON.FFIELD'
5366 !      include 'COMMON.IOUNITS'
5367 !      include 'COMMON.CONTROL'
5368       real(kind=8),dimension(3) :: ggg
5369 !el local variables
5370       integer :: i,iint,j,k,iteli,itypj
5371       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5372                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5373
5374       evdw2=0.0D0
5375       evdw2_14=0.0d0
5376       r0_scp=4.5d0
5377 !d    print '(a)','Enter ESCP'
5378 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5379       do i=iatscp_s,iatscp_e
5380         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5381         iteli=itel(i)
5382         xi=0.5D0*(c(1,i)+c(1,i+1))
5383         yi=0.5D0*(c(2,i)+c(2,i+1))
5384         zi=0.5D0*(c(3,i)+c(3,i+1))
5385
5386         do iint=1,nscp_gr(i)
5387
5388         do j=iscpstart(i,iint),iscpend(i,iint)
5389           if (itype(j,1).eq.ntyp1) cycle
5390           itypj=iabs(itype(j,1))
5391 ! Uncomment following three lines for SC-p interactions
5392 !         xj=c(1,nres+j)-xi
5393 !         yj=c(2,nres+j)-yi
5394 !         zj=c(3,nres+j)-zi
5395 ! Uncomment following three lines for Ca-p interactions
5396           xj=c(1,j)-xi
5397           yj=c(2,j)-yi
5398           zj=c(3,j)-zi
5399           rij=xj*xj+yj*yj+zj*zj
5400           r0ij=r0_scp
5401           r0ijsq=r0ij*r0ij
5402           if (rij.lt.r0ijsq) then
5403             evdwij=0.25d0*(rij-r0ijsq)**2
5404             fac=rij-r0ijsq
5405           else
5406             evdwij=0.0d0
5407             fac=0.0d0
5408           endif
5409           evdw2=evdw2+evdwij
5410 !
5411 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5412 !
5413           ggg(1)=xj*fac
5414           ggg(2)=yj*fac
5415           ggg(3)=zj*fac
5416 !grad          if (j.lt.i) then
5417 !d          write (iout,*) 'j<i'
5418 ! Uncomment following three lines for SC-p interactions
5419 !           do k=1,3
5420 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5421 !           enddo
5422 !grad          else
5423 !d          write (iout,*) 'j>i'
5424 !grad            do k=1,3
5425 !grad              ggg(k)=-ggg(k)
5426 ! Uncomment following line for SC-p interactions
5427 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5428 !grad            enddo
5429 !grad          endif
5430 !grad          do k=1,3
5431 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5432 !grad          enddo
5433 !grad          kstart=min0(i+1,j)
5434 !grad          kend=max0(i-1,j-1)
5435 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5436 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5437 !grad          do k=kstart,kend
5438 !grad            do l=1,3
5439 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5440 !grad            enddo
5441 !grad          enddo
5442           do k=1,3
5443             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5444             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5445           enddo
5446         enddo
5447
5448         enddo ! iint
5449       enddo ! i
5450       return
5451       end subroutine escp_soft_sphere
5452 !-----------------------------------------------------------------------------
5453       subroutine escp(evdw2,evdw2_14)
5454 !
5455 ! This subroutine calculates the excluded-volume interaction energy between
5456 ! peptide-group centers and side chains and its gradient in virtual-bond and
5457 ! side-chain vectors.
5458 !
5459 !      implicit real*8 (a-h,o-z)
5460 !      include 'DIMENSIONS'
5461 !      include 'COMMON.GEO'
5462 !      include 'COMMON.VAR'
5463 !      include 'COMMON.LOCAL'
5464 !      include 'COMMON.CHAIN'
5465 !      include 'COMMON.DERIV'
5466 !      include 'COMMON.INTERACT'
5467 !      include 'COMMON.FFIELD'
5468 !      include 'COMMON.IOUNITS'
5469 !      include 'COMMON.CONTROL'
5470       real(kind=8),dimension(3) :: ggg
5471 !el local variables
5472       integer :: i,iint,j,k,iteli,itypj,subchap
5473       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5474                    e1,e2,evdwij,rij
5475       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5476                     dist_temp, dist_init
5477       integer xshift,yshift,zshift
5478
5479       evdw2=0.0D0
5480       evdw2_14=0.0d0
5481 !d    print '(a)','Enter ESCP'
5482 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5483       do i=iatscp_s,iatscp_e
5484         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5485         iteli=itel(i)
5486         xi=0.5D0*(c(1,i)+c(1,i+1))
5487         yi=0.5D0*(c(2,i)+c(2,i+1))
5488         zi=0.5D0*(c(3,i)+c(3,i+1))
5489           xi=mod(xi,boxxsize)
5490           if (xi.lt.0) xi=xi+boxxsize
5491           yi=mod(yi,boxysize)
5492           if (yi.lt.0) yi=yi+boxysize
5493           zi=mod(zi,boxzsize)
5494           if (zi.lt.0) zi=zi+boxzsize
5495
5496         do iint=1,nscp_gr(i)
5497
5498         do j=iscpstart(i,iint),iscpend(i,iint)
5499           itypj=iabs(itype(j,1))
5500           if (itypj.eq.ntyp1) cycle
5501 ! Uncomment following three lines for SC-p interactions
5502 !         xj=c(1,nres+j)-xi
5503 !         yj=c(2,nres+j)-yi
5504 !         zj=c(3,nres+j)-zi
5505 ! Uncomment following three lines for Ca-p interactions
5506 !          xj=c(1,j)-xi
5507 !          yj=c(2,j)-yi
5508 !          zj=c(3,j)-zi
5509           xj=c(1,j)
5510           yj=c(2,j)
5511           zj=c(3,j)
5512           xj=mod(xj,boxxsize)
5513           if (xj.lt.0) xj=xj+boxxsize
5514           yj=mod(yj,boxysize)
5515           if (yj.lt.0) yj=yj+boxysize
5516           zj=mod(zj,boxzsize)
5517           if (zj.lt.0) zj=zj+boxzsize
5518       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5519       xj_safe=xj
5520       yj_safe=yj
5521       zj_safe=zj
5522       subchap=0
5523       do xshift=-1,1
5524       do yshift=-1,1
5525       do zshift=-1,1
5526           xj=xj_safe+xshift*boxxsize
5527           yj=yj_safe+yshift*boxysize
5528           zj=zj_safe+zshift*boxzsize
5529           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5530           if(dist_temp.lt.dist_init) then
5531             dist_init=dist_temp
5532             xj_temp=xj
5533             yj_temp=yj
5534             zj_temp=zj
5535             subchap=1
5536           endif
5537        enddo
5538        enddo
5539        enddo
5540        if (subchap.eq.1) then
5541           xj=xj_temp-xi
5542           yj=yj_temp-yi
5543           zj=zj_temp-zi
5544        else
5545           xj=xj_safe-xi
5546           yj=yj_safe-yi
5547           zj=zj_safe-zi
5548        endif
5549
5550           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5551           rij=dsqrt(1.0d0/rrij)
5552             sss_ele_cut=sscale_ele(rij)
5553             sss_ele_grad=sscagrad_ele(rij)
5554 !            print *,sss_ele_cut,sss_ele_grad,&
5555 !            (rij),r_cut_ele,rlamb_ele
5556             if (sss_ele_cut.le.0.0) cycle
5557           fac=rrij**expon2
5558           e1=fac*fac*aad(itypj,iteli)
5559           e2=fac*bad(itypj,iteli)
5560           if (iabs(j-i) .le. 2) then
5561             e1=scal14*e1
5562             e2=scal14*e2
5563             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5564           endif
5565           evdwij=e1+e2
5566           evdw2=evdw2+evdwij*sss_ele_cut
5567 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5568 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5569           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5570              'evdw2',i,j,evdwij
5571 !
5572 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5573 !
5574           fac=-(evdwij+e1)*rrij*sss_ele_cut
5575           fac=fac+evdwij*sss_ele_grad/rij/expon
5576           ggg(1)=xj*fac
5577           ggg(2)=yj*fac
5578           ggg(3)=zj*fac
5579 !grad          if (j.lt.i) then
5580 !d          write (iout,*) 'j<i'
5581 ! Uncomment following three lines for SC-p interactions
5582 !           do k=1,3
5583 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5584 !           enddo
5585 !grad          else
5586 !d          write (iout,*) 'j>i'
5587 !grad            do k=1,3
5588 !grad              ggg(k)=-ggg(k)
5589 ! Uncomment following line for SC-p interactions
5590 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5591 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5592 !grad            enddo
5593 !grad          endif
5594 !grad          do k=1,3
5595 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5596 !grad          enddo
5597 !grad          kstart=min0(i+1,j)
5598 !grad          kend=max0(i-1,j-1)
5599 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5600 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5601 !grad          do k=kstart,kend
5602 !grad            do l=1,3
5603 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5604 !grad            enddo
5605 !grad          enddo
5606           do k=1,3
5607             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5608             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5609           enddo
5610         enddo
5611
5612         enddo ! iint
5613       enddo ! i
5614       do i=1,nct
5615         do j=1,3
5616           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5617           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5618           gradx_scp(j,i)=expon*gradx_scp(j,i)
5619         enddo
5620       enddo
5621 !******************************************************************************
5622 !
5623 !                              N O T E !!!
5624 !
5625 ! To save time the factor EXPON has been extracted from ALL components
5626 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5627 ! use!
5628 !
5629 !******************************************************************************
5630       return
5631       end subroutine escp
5632 !-----------------------------------------------------------------------------
5633       subroutine edis(ehpb)
5634 !
5635 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5636 !
5637 !      implicit real*8 (a-h,o-z)
5638 !      include 'DIMENSIONS'
5639 !      include 'COMMON.SBRIDGE'
5640 !      include 'COMMON.CHAIN'
5641 !      include 'COMMON.DERIV'
5642 !      include 'COMMON.VAR'
5643 !      include 'COMMON.INTERACT'
5644 !      include 'COMMON.IOUNITS'
5645       real(kind=8),dimension(3) :: ggg
5646 !el local variables
5647       integer :: i,j,ii,jj,iii,jjj,k
5648       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5649
5650       ehpb=0.0D0
5651 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5652 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5653       if (link_end.eq.0) return
5654       do i=link_start,link_end
5655 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5656 ! CA-CA distance used in regularization of structure.
5657         ii=ihpb(i)
5658         jj=jhpb(i)
5659 ! iii and jjj point to the residues for which the distance is assigned.
5660         if (ii.gt.nres) then
5661           iii=ii-nres
5662           jjj=jj-nres
5663         else
5664           iii=ii
5665           jjj=jj
5666         endif
5667 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5668 !     &    dhpb(i),dhpb1(i),forcon(i)
5669 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5670 !    distance and angle dependent SS bond potential.
5671 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5672 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5673         if (.not.dyn_ss .and. i.le.nss) then
5674 ! 15/02/13 CC dynamic SSbond - additional check
5675          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5676         iabs(itype(jjj,1)).eq.1) then
5677           call ssbond_ene(iii,jjj,eij)
5678           ehpb=ehpb+2*eij
5679 !d          write (iout,*) "eij",eij
5680          endif
5681         else if (ii.gt.nres .and. jj.gt.nres) then
5682 !c Restraints from contact prediction
5683           dd=dist(ii,jj)
5684           if (constr_dist.eq.11) then
5685             ehpb=ehpb+fordepth(i)**4.0d0 &
5686                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5687             fac=fordepth(i)**4.0d0 &
5688                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5689           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5690             ehpb,fordepth(i),dd
5691            else
5692           if (dhpb1(i).gt.0.0d0) then
5693             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5694             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5695 !c            write (iout,*) "beta nmr",
5696 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5697           else
5698             dd=dist(ii,jj)
5699             rdis=dd-dhpb(i)
5700 !C Get the force constant corresponding to this distance.
5701             waga=forcon(i)
5702 !C Calculate the contribution to energy.
5703             ehpb=ehpb+waga*rdis*rdis
5704 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5705 !C
5706 !C Evaluate gradient.
5707 !C
5708             fac=waga*rdis/dd
5709           endif
5710           endif
5711           do j=1,3
5712             ggg(j)=fac*(c(j,jj)-c(j,ii))
5713           enddo
5714           do j=1,3
5715             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5716             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5717           enddo
5718           do k=1,3
5719             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5720             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5721           enddo
5722         else
5723           dd=dist(ii,jj)
5724           if (constr_dist.eq.11) then
5725             ehpb=ehpb+fordepth(i)**4.0d0 &
5726                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5727             fac=fordepth(i)**4.0d0 &
5728                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5729           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5730          ehpb,fordepth(i),dd
5731            else
5732           if (dhpb1(i).gt.0.0d0) then
5733             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5734             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5735 !c            write (iout,*) "alph nmr",
5736 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5737           else
5738             rdis=dd-dhpb(i)
5739 !C Get the force constant corresponding to this distance.
5740             waga=forcon(i)
5741 !C Calculate the contribution to energy.
5742             ehpb=ehpb+waga*rdis*rdis
5743 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5744 !C
5745 !C Evaluate gradient.
5746 !C
5747             fac=waga*rdis/dd
5748           endif
5749           endif
5750
5751             do j=1,3
5752               ggg(j)=fac*(c(j,jj)-c(j,ii))
5753             enddo
5754 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5755 !C If this is a SC-SC distance, we need to calculate the contributions to the
5756 !C Cartesian gradient in the SC vectors (ghpbx).
5757           if (iii.lt.ii) then
5758           do j=1,3
5759             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5760             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5761           enddo
5762           endif
5763 !cgrad        do j=iii,jjj-1
5764 !cgrad          do k=1,3
5765 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5766 !cgrad          enddo
5767 !cgrad        enddo
5768           do k=1,3
5769             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5770             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5771           enddo
5772         endif
5773       enddo
5774       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5775
5776       return
5777       end subroutine edis
5778 !-----------------------------------------------------------------------------
5779       subroutine ssbond_ene(i,j,eij)
5780 !
5781 ! Calculate the distance and angle dependent SS-bond potential energy
5782 ! using a free-energy function derived based on RHF/6-31G** ab initio
5783 ! calculations of diethyl disulfide.
5784 !
5785 ! A. Liwo and U. Kozlowska, 11/24/03
5786 !
5787 !      implicit real*8 (a-h,o-z)
5788 !      include 'DIMENSIONS'
5789 !      include 'COMMON.SBRIDGE'
5790 !      include 'COMMON.CHAIN'
5791 !      include 'COMMON.DERIV'
5792 !      include 'COMMON.LOCAL'
5793 !      include 'COMMON.INTERACT'
5794 !      include 'COMMON.VAR'
5795 !      include 'COMMON.IOUNITS'
5796       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5797 !el local variables
5798       integer :: i,j,itypi,itypj,k
5799       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5800                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5801                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5802                    cosphi,ggk
5803
5804       itypi=iabs(itype(i,1))
5805       xi=c(1,nres+i)
5806       yi=c(2,nres+i)
5807       zi=c(3,nres+i)
5808       dxi=dc_norm(1,nres+i)
5809       dyi=dc_norm(2,nres+i)
5810       dzi=dc_norm(3,nres+i)
5811 !      dsci_inv=dsc_inv(itypi)
5812       dsci_inv=vbld_inv(nres+i)
5813       itypj=iabs(itype(j,1))
5814 !      dscj_inv=dsc_inv(itypj)
5815       dscj_inv=vbld_inv(nres+j)
5816       xj=c(1,nres+j)-xi
5817       yj=c(2,nres+j)-yi
5818       zj=c(3,nres+j)-zi
5819       dxj=dc_norm(1,nres+j)
5820       dyj=dc_norm(2,nres+j)
5821       dzj=dc_norm(3,nres+j)
5822       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5823       rij=dsqrt(rrij)
5824       erij(1)=xj*rij
5825       erij(2)=yj*rij
5826       erij(3)=zj*rij
5827       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5828       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5829       om12=dxi*dxj+dyi*dyj+dzi*dzj
5830       do k=1,3
5831         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5832         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5833       enddo
5834       rij=1.0d0/rij
5835       deltad=rij-d0cm
5836       deltat1=1.0d0-om1
5837       deltat2=1.0d0+om2
5838       deltat12=om2-om1+2.0d0
5839       cosphi=om12-om1*om2
5840       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5841         +akct*deltad*deltat12 &
5842         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5843 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5844 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5845 !     &  " deltat12",deltat12," eij",eij
5846       ed=2*akcm*deltad+akct*deltat12
5847       pom1=akct*deltad
5848       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5849       eom1=-2*akth*deltat1-pom1-om2*pom2
5850       eom2= 2*akth*deltat2+pom1-om1*pom2
5851       eom12=pom2
5852       do k=1,3
5853         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5854         ghpbx(k,i)=ghpbx(k,i)-ggk &
5855                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5856                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5857         ghpbx(k,j)=ghpbx(k,j)+ggk &
5858                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5859                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5860         ghpbc(k,i)=ghpbc(k,i)-ggk
5861         ghpbc(k,j)=ghpbc(k,j)+ggk
5862       enddo
5863 !
5864 ! Calculate the components of the gradient in DC and X
5865 !
5866 !grad      do k=i,j-1
5867 !grad        do l=1,3
5868 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5869 !grad        enddo
5870 !grad      enddo
5871       return
5872       end subroutine ssbond_ene
5873 !-----------------------------------------------------------------------------
5874       subroutine ebond(estr)
5875 !
5876 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5877 !
5878 !      implicit real*8 (a-h,o-z)
5879 !      include 'DIMENSIONS'
5880 !      include 'COMMON.LOCAL'
5881 !      include 'COMMON.GEO'
5882 !      include 'COMMON.INTERACT'
5883 !      include 'COMMON.DERIV'
5884 !      include 'COMMON.VAR'
5885 !      include 'COMMON.CHAIN'
5886 !      include 'COMMON.IOUNITS'
5887 !      include 'COMMON.NAMES'
5888 !      include 'COMMON.FFIELD'
5889 !      include 'COMMON.CONTROL'
5890 !      include 'COMMON.SETUP'
5891       real(kind=8),dimension(3) :: u,ud
5892 !el local variables
5893       integer :: i,j,iti,nbi,k
5894       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5895                    uprod1,uprod2
5896
5897       estr=0.0d0
5898       estr1=0.0d0
5899 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5900 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5901
5902       do i=ibondp_start,ibondp_end
5903         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5904         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5905 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5906 !C          do j=1,3
5907 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5908 !C            *dc(j,i-1)/vbld(i)
5909 !C          enddo
5910 !C          if (energy_dec) write(iout,*) &
5911 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5912         diff = vbld(i)-vbldpDUM
5913         else
5914         diff = vbld(i)-vbldp0
5915         endif
5916         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5917            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5918         estr=estr+diff*diff
5919         do j=1,3
5920           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5921         enddo
5922 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5923 !        endif
5924       enddo
5925       estr=0.5d0*AKP*estr+estr1
5926 !      print *,"estr_bb",estr,AKP
5927 !
5928 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5929 !
5930       do i=ibond_start,ibond_end
5931         iti=iabs(itype(i,1))
5932         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5933         if (iti.ne.10 .and. iti.ne.ntyp1) then
5934           nbi=nbondterm(iti)
5935           if (nbi.eq.1) then
5936             diff=vbld(i+nres)-vbldsc0(1,iti)
5937             if (energy_dec) write (iout,*) &
5938             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5939             AKSC(1,iti),AKSC(1,iti)*diff*diff
5940             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5941 !            print *,"estr_sc",estr
5942             do j=1,3
5943               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5944             enddo
5945           else
5946             do j=1,nbi
5947               diff=vbld(i+nres)-vbldsc0(j,iti)
5948               ud(j)=aksc(j,iti)*diff
5949               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5950             enddo
5951             uprod=u(1)
5952             do j=2,nbi
5953               uprod=uprod*u(j)
5954             enddo
5955             usum=0.0d0
5956             usumsqder=0.0d0
5957             do j=1,nbi
5958               uprod1=1.0d0
5959               uprod2=1.0d0
5960               do k=1,nbi
5961                 if (k.ne.j) then
5962                   uprod1=uprod1*u(k)
5963                   uprod2=uprod2*u(k)*u(k)
5964                 endif
5965               enddo
5966               usum=usum+uprod1
5967               usumsqder=usumsqder+ud(j)*uprod2
5968             enddo
5969             estr=estr+uprod/usum
5970 !            print *,"estr_sc",estr,i
5971
5972              if (energy_dec) write (iout,*) &
5973             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5974             AKSC(1,iti),uprod/usum
5975             do j=1,3
5976              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5977             enddo
5978           endif
5979         endif
5980       enddo
5981       return
5982       end subroutine ebond
5983 #ifdef CRYST_THETA
5984 !-----------------------------------------------------------------------------
5985       subroutine ebend(etheta)
5986 !
5987 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5988 ! angles gamma and its derivatives in consecutive thetas and gammas.
5989 !
5990       use comm_calcthet
5991 !      implicit real*8 (a-h,o-z)
5992 !      include 'DIMENSIONS'
5993 !      include 'COMMON.LOCAL'
5994 !      include 'COMMON.GEO'
5995 !      include 'COMMON.INTERACT'
5996 !      include 'COMMON.DERIV'
5997 !      include 'COMMON.VAR'
5998 !      include 'COMMON.CHAIN'
5999 !      include 'COMMON.IOUNITS'
6000 !      include 'COMMON.NAMES'
6001 !      include 'COMMON.FFIELD'
6002 !      include 'COMMON.CONTROL'
6003 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6004 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6005 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6006 !el      integer :: it
6007 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6008 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6009 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6010 !el local variables
6011       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6012        ichir21,ichir22
6013       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6014        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6015        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6016       real(kind=8),dimension(2) :: y,z
6017
6018       delta=0.02d0*pi
6019 !      time11=dexp(-2*time)
6020 !      time12=1.0d0
6021       etheta=0.0D0
6022 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6023       do i=ithet_start,ithet_end
6024         if (itype(i-1,1).eq.ntyp1) cycle
6025 ! Zero the energy function and its derivative at 0 or pi.
6026         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6027         it=itype(i-1,1)
6028         ichir1=isign(1,itype(i-2,1))
6029         ichir2=isign(1,itype(i,1))
6030          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6031          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6032          if (itype(i-1,1).eq.10) then
6033           itype1=isign(10,itype(i-2,1))
6034           ichir11=isign(1,itype(i-2,1))
6035           ichir12=isign(1,itype(i-2,1))
6036           itype2=isign(10,itype(i,1))
6037           ichir21=isign(1,itype(i,1))
6038           ichir22=isign(1,itype(i,1))
6039          endif
6040
6041         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6042 #ifdef OSF
6043           phii=phi(i)
6044           if (phii.ne.phii) phii=150.0
6045 #else
6046           phii=phi(i)
6047 #endif
6048           y(1)=dcos(phii)
6049           y(2)=dsin(phii)
6050         else
6051           y(1)=0.0D0
6052           y(2)=0.0D0
6053         endif
6054         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6055 #ifdef OSF
6056           phii1=phi(i+1)
6057           if (phii1.ne.phii1) phii1=150.0
6058           phii1=pinorm(phii1)
6059           z(1)=cos(phii1)
6060 #else
6061           phii1=phi(i+1)
6062           z(1)=dcos(phii1)
6063 #endif
6064           z(2)=dsin(phii1)
6065         else
6066           z(1)=0.0D0
6067           z(2)=0.0D0
6068         endif
6069 ! Calculate the "mean" value of theta from the part of the distribution
6070 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6071 ! In following comments this theta will be referred to as t_c.
6072         thet_pred_mean=0.0d0
6073         do k=1,2
6074             athetk=athet(k,it,ichir1,ichir2)
6075             bthetk=bthet(k,it,ichir1,ichir2)
6076           if (it.eq.10) then
6077              athetk=athet(k,itype1,ichir11,ichir12)
6078              bthetk=bthet(k,itype2,ichir21,ichir22)
6079           endif
6080          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6081         enddo
6082         dthett=thet_pred_mean*ssd
6083         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6084 ! Derivatives of the "mean" values in gamma1 and gamma2.
6085         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6086                +athet(2,it,ichir1,ichir2)*y(1))*ss
6087         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6088                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6089          if (it.eq.10) then
6090         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6091              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6092         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6093                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6094          endif
6095         if (theta(i).gt.pi-delta) then
6096           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6097                E_tc0)
6098           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6099           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6100           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6101               E_theta)
6102           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6103               E_tc)
6104         else if (theta(i).lt.delta) then
6105           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6106           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6107           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6108               E_theta)
6109           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6110           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6111               E_tc)
6112         else
6113           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6114               E_theta,E_tc)
6115         endif
6116         etheta=etheta+ethetai
6117         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6118             'ebend',i,ethetai
6119         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6120         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6121         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6122       enddo
6123 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6124
6125 ! Ufff.... We've done all this!!!
6126       return
6127       end subroutine ebend
6128 !-----------------------------------------------------------------------------
6129       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6130
6131       use comm_calcthet
6132 !      implicit real*8 (a-h,o-z)
6133 !      include 'DIMENSIONS'
6134 !      include 'COMMON.LOCAL'
6135 !      include 'COMMON.IOUNITS'
6136 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6137 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6138 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6139       integer :: i,j,k
6140       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6141 !el      integer :: it
6142 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6143 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6144 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6145 !el local variables
6146       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6147        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6148
6149 ! Calculate the contributions to both Gaussian lobes.
6150 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6151 ! The "polynomial part" of the "standard deviation" of this part of
6152 ! the distribution.
6153         sig=polthet(3,it)
6154         do j=2,0,-1
6155           sig=sig*thet_pred_mean+polthet(j,it)
6156         enddo
6157 ! Derivative of the "interior part" of the "standard deviation of the"
6158 ! gamma-dependent Gaussian lobe in t_c.
6159         sigtc=3*polthet(3,it)
6160         do j=2,1,-1
6161           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6162         enddo
6163         sigtc=sig*sigtc
6164 ! Set the parameters of both Gaussian lobes of the distribution.
6165 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6166         fac=sig*sig+sigc0(it)
6167         sigcsq=fac+fac
6168         sigc=1.0D0/sigcsq
6169 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6170         sigsqtc=-4.0D0*sigcsq*sigtc
6171 !       print *,i,sig,sigtc,sigsqtc
6172 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6173         sigtc=-sigtc/(fac*fac)
6174 ! Following variable is sigma(t_c)**(-2)
6175         sigcsq=sigcsq*sigcsq
6176         sig0i=sig0(it)
6177         sig0inv=1.0D0/sig0i**2
6178         delthec=thetai-thet_pred_mean
6179         delthe0=thetai-theta0i
6180         term1=-0.5D0*sigcsq*delthec*delthec
6181         term2=-0.5D0*sig0inv*delthe0*delthe0
6182 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6183 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6184 ! to the energy (this being the log of the distribution) at the end of energy
6185 ! term evaluation for this virtual-bond angle.
6186         if (term1.gt.term2) then
6187           termm=term1
6188           term2=dexp(term2-termm)
6189           term1=1.0d0
6190         else
6191           termm=term2
6192           term1=dexp(term1-termm)
6193           term2=1.0d0
6194         endif
6195 ! The ratio between the gamma-independent and gamma-dependent lobes of
6196 ! the distribution is a Gaussian function of thet_pred_mean too.
6197         diffak=gthet(2,it)-thet_pred_mean
6198         ratak=diffak/gthet(3,it)**2
6199         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6200 ! Let's differentiate it in thet_pred_mean NOW.
6201         aktc=ak*ratak
6202 ! Now put together the distribution terms to make complete distribution.
6203         termexp=term1+ak*term2
6204         termpre=sigc+ak*sig0i
6205 ! Contribution of the bending energy from this theta is just the -log of
6206 ! the sum of the contributions from the two lobes and the pre-exponential
6207 ! factor. Simple enough, isn't it?
6208         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6209 ! NOW the derivatives!!!
6210 ! 6/6/97 Take into account the deformation.
6211         E_theta=(delthec*sigcsq*term1 &
6212              +ak*delthe0*sig0inv*term2)/termexp
6213         E_tc=((sigtc+aktc*sig0i)/termpre &
6214             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6215              aktc*term2)/termexp)
6216       return
6217       end subroutine theteng
6218 #else
6219 !-----------------------------------------------------------------------------
6220       subroutine ebend(etheta)
6221 !
6222 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6223 ! angles gamma and its derivatives in consecutive thetas and gammas.
6224 ! ab initio-derived potentials from
6225 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6226 !
6227 !      implicit real*8 (a-h,o-z)
6228 !      include 'DIMENSIONS'
6229 !      include 'COMMON.LOCAL'
6230 !      include 'COMMON.GEO'
6231 !      include 'COMMON.INTERACT'
6232 !      include 'COMMON.DERIV'
6233 !      include 'COMMON.VAR'
6234 !      include 'COMMON.CHAIN'
6235 !      include 'COMMON.IOUNITS'
6236 !      include 'COMMON.NAMES'
6237 !      include 'COMMON.FFIELD'
6238 !      include 'COMMON.CONTROL'
6239       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6240       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6241       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6242       logical :: lprn=.false., lprn1=.false.
6243 !el local variables
6244       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6245       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6246       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6247 ! local variables for constrains
6248       real(kind=8) :: difi,thetiii
6249        integer itheta
6250 !      write(iout,*) "in ebend",ithet_start,ithet_end
6251       call flush(iout)
6252       etheta=0.0D0
6253       do i=ithet_start,ithet_end
6254         if (itype(i-1,1).eq.ntyp1) cycle
6255         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6256         if (iabs(itype(i+1,1)).eq.20) iblock=2
6257         if (iabs(itype(i+1,1)).ne.20) iblock=1
6258         dethetai=0.0d0
6259         dephii=0.0d0
6260         dephii1=0.0d0
6261         theti2=0.5d0*theta(i)
6262         ityp2=ithetyp((itype(i-1,1)))
6263         do k=1,nntheterm
6264           coskt(k)=dcos(k*theti2)
6265           sinkt(k)=dsin(k*theti2)
6266         enddo
6267         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6268 #ifdef OSF
6269           phii=phi(i)
6270           if (phii.ne.phii) phii=150.0
6271 #else
6272           phii=phi(i)
6273 #endif
6274           ityp1=ithetyp((itype(i-2,1)))
6275 ! propagation of chirality for glycine type
6276           do k=1,nsingle
6277             cosph1(k)=dcos(k*phii)
6278             sinph1(k)=dsin(k*phii)
6279           enddo
6280         else
6281           phii=0.0d0
6282           ityp1=ithetyp(itype(i-2,1))
6283           do k=1,nsingle
6284             cosph1(k)=0.0d0
6285             sinph1(k)=0.0d0
6286           enddo
6287         endif
6288         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6289 #ifdef OSF
6290           phii1=phi(i+1)
6291           if (phii1.ne.phii1) phii1=150.0
6292           phii1=pinorm(phii1)
6293 #else
6294           phii1=phi(i+1)
6295 #endif
6296           ityp3=ithetyp((itype(i,1)))
6297           do k=1,nsingle
6298             cosph2(k)=dcos(k*phii1)
6299             sinph2(k)=dsin(k*phii1)
6300           enddo
6301         else
6302           phii1=0.0d0
6303           ityp3=ithetyp(itype(i,1))
6304           do k=1,nsingle
6305             cosph2(k)=0.0d0
6306             sinph2(k)=0.0d0
6307           enddo
6308         endif
6309         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6310         do k=1,ndouble
6311           do l=1,k-1
6312             ccl=cosph1(l)*cosph2(k-l)
6313             ssl=sinph1(l)*sinph2(k-l)
6314             scl=sinph1(l)*cosph2(k-l)
6315             csl=cosph1(l)*sinph2(k-l)
6316             cosph1ph2(l,k)=ccl-ssl
6317             cosph1ph2(k,l)=ccl+ssl
6318             sinph1ph2(l,k)=scl+csl
6319             sinph1ph2(k,l)=scl-csl
6320           enddo
6321         enddo
6322         if (lprn) then
6323         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6324           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6325         write (iout,*) "coskt and sinkt"
6326         do k=1,nntheterm
6327           write (iout,*) k,coskt(k),sinkt(k)
6328         enddo
6329         endif
6330         do k=1,ntheterm
6331           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6332           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6333             *coskt(k)
6334           if (lprn) &
6335           write (iout,*) "k",k,&
6336            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6337            " ethetai",ethetai
6338         enddo
6339         if (lprn) then
6340         write (iout,*) "cosph and sinph"
6341         do k=1,nsingle
6342           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6343         enddo
6344         write (iout,*) "cosph1ph2 and sinph2ph2"
6345         do k=2,ndouble
6346           do l=1,k-1
6347             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6348                sinph1ph2(l,k),sinph1ph2(k,l)
6349           enddo
6350         enddo
6351         write(iout,*) "ethetai",ethetai
6352         endif
6353         do m=1,ntheterm2
6354           do k=1,nsingle
6355             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6356                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6357                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6358                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6359             ethetai=ethetai+sinkt(m)*aux
6360             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6361             dephii=dephii+k*sinkt(m)* &
6362                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6363                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6364             dephii1=dephii1+k*sinkt(m)* &
6365                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6366                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6367             if (lprn) &
6368             write (iout,*) "m",m," k",k," bbthet", &
6369                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6370                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6371                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6372                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6373           enddo
6374         enddo
6375         if (lprn) &
6376         write(iout,*) "ethetai",ethetai
6377         do m=1,ntheterm3
6378           do k=2,ndouble
6379             do l=1,k-1
6380               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6381                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6382                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6383                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6384               ethetai=ethetai+sinkt(m)*aux
6385               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6386               dephii=dephii+l*sinkt(m)* &
6387                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6388                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6389                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6390                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6391               dephii1=dephii1+(k-l)*sinkt(m)* &
6392                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6393                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6394                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6395                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6396               if (lprn) then
6397               write (iout,*) "m",m," k",k," l",l," ffthet",&
6398                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6399                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6400                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6401                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6402                   " ethetai",ethetai
6403               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6404                   cosph1ph2(k,l)*sinkt(m),&
6405                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6406               endif
6407             enddo
6408           enddo
6409         enddo
6410 10      continue
6411 !        lprn1=.true.
6412         if (lprn1) &
6413           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6414          i,theta(i)*rad2deg,phii*rad2deg,&
6415          phii1*rad2deg,ethetai
6416 !        lprn1=.false.
6417         etheta=etheta+ethetai
6418         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6419                                     'ebend',i,ethetai
6420         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6421         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6422         gloc(nphi+i-2,icg)=wang*dethetai
6423       enddo
6424 !-----------thete constrains
6425 !      if (tor_mode.ne.2) then
6426
6427       return
6428       end subroutine ebend
6429 #endif
6430 #ifdef CRYST_SC
6431 !-----------------------------------------------------------------------------
6432       subroutine esc(escloc)
6433 ! Calculate the local energy of a side chain and its derivatives in the
6434 ! corresponding virtual-bond valence angles THETA and the spherical angles
6435 ! ALPHA and OMEGA.
6436 !
6437       use comm_sccalc
6438 !      implicit real*8 (a-h,o-z)
6439 !      include 'DIMENSIONS'
6440 !      include 'COMMON.GEO'
6441 !      include 'COMMON.LOCAL'
6442 !      include 'COMMON.VAR'
6443 !      include 'COMMON.INTERACT'
6444 !      include 'COMMON.DERIV'
6445 !      include 'COMMON.CHAIN'
6446 !      include 'COMMON.IOUNITS'
6447 !      include 'COMMON.NAMES'
6448 !      include 'COMMON.FFIELD'
6449 !      include 'COMMON.CONTROL'
6450       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6451          ddersc0,ddummy,xtemp,temp
6452 !el      real(kind=8) :: time11,time12,time112,theti
6453       real(kind=8) :: escloc,delta
6454 !el      integer :: it,nlobit
6455 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6456 !el local variables
6457       integer :: i,k
6458       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6459        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6460       delta=0.02d0*pi
6461       escloc=0.0D0
6462 !     write (iout,'(a)') 'ESC'
6463       do i=loc_start,loc_end
6464         it=itype(i,1)
6465         if (it.eq.ntyp1) cycle
6466         if (it.eq.10) goto 1
6467         nlobit=nlob(iabs(it))
6468 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6469 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6470         theti=theta(i+1)-pipol
6471         x(1)=dtan(theti)
6472         x(2)=alph(i)
6473         x(3)=omeg(i)
6474
6475         if (x(2).gt.pi-delta) then
6476           xtemp(1)=x(1)
6477           xtemp(2)=pi-delta
6478           xtemp(3)=x(3)
6479           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6480           xtemp(2)=pi
6481           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6482           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6483               escloci,dersc(2))
6484           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6485               ddersc0(1),dersc(1))
6486           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6487               ddersc0(3),dersc(3))
6488           xtemp(2)=pi-delta
6489           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6490           xtemp(2)=pi
6491           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6492           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6493                   dersc0(2),esclocbi,dersc02)
6494           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6495                   dersc12,dersc01)
6496           call splinthet(x(2),0.5d0*delta,ss,ssd)
6497           dersc0(1)=dersc01
6498           dersc0(2)=dersc02
6499           dersc0(3)=0.0d0
6500           do k=1,3
6501             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6502           enddo
6503           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6504 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6505 !    &             esclocbi,ss,ssd
6506           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6507 !         escloci=esclocbi
6508 !         write (iout,*) escloci
6509         else if (x(2).lt.delta) then
6510           xtemp(1)=x(1)
6511           xtemp(2)=delta
6512           xtemp(3)=x(3)
6513           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6514           xtemp(2)=0.0d0
6515           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6516           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6517               escloci,dersc(2))
6518           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6519               ddersc0(1),dersc(1))
6520           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6521               ddersc0(3),dersc(3))
6522           xtemp(2)=delta
6523           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6524           xtemp(2)=0.0d0
6525           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6526           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6527                   dersc0(2),esclocbi,dersc02)
6528           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6529                   dersc12,dersc01)
6530           dersc0(1)=dersc01
6531           dersc0(2)=dersc02
6532           dersc0(3)=0.0d0
6533           call splinthet(x(2),0.5d0*delta,ss,ssd)
6534           do k=1,3
6535             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6536           enddo
6537           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6538 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6539 !    &             esclocbi,ss,ssd
6540           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6541 !         write (iout,*) escloci
6542         else
6543           call enesc(x,escloci,dersc,ddummy,.false.)
6544         endif
6545
6546         escloc=escloc+escloci
6547         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6548            'escloc',i,escloci
6549 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6550
6551         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6552          wscloc*dersc(1)
6553         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6554         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6555     1   continue
6556       enddo
6557       return
6558       end subroutine esc
6559 !-----------------------------------------------------------------------------
6560       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6561
6562       use comm_sccalc
6563 !      implicit real*8 (a-h,o-z)
6564 !      include 'DIMENSIONS'
6565 !      include 'COMMON.GEO'
6566 !      include 'COMMON.LOCAL'
6567 !      include 'COMMON.IOUNITS'
6568 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6569       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6570       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6571       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6572       real(kind=8) :: escloci
6573       logical :: mixed
6574 !el local variables
6575       integer :: j,iii,l,k !el,it,nlobit
6576       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6577 !el       time11,time12,time112
6578 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6579         escloc_i=0.0D0
6580         do j=1,3
6581           dersc(j)=0.0D0
6582           if (mixed) ddersc(j)=0.0d0
6583         enddo
6584         x3=x(3)
6585
6586 ! Because of periodicity of the dependence of the SC energy in omega we have
6587 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6588 ! To avoid underflows, first compute & store the exponents.
6589
6590         do iii=-1,1
6591
6592           x(3)=x3+iii*dwapi
6593
6594           do j=1,nlobit
6595             do k=1,3
6596               z(k)=x(k)-censc(k,j,it)
6597             enddo
6598             do k=1,3
6599               Axk=0.0D0
6600               do l=1,3
6601                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6602               enddo
6603               Ax(k,j,iii)=Axk
6604             enddo
6605             expfac=0.0D0
6606             do k=1,3
6607               expfac=expfac+Ax(k,j,iii)*z(k)
6608             enddo
6609             contr(j,iii)=expfac
6610           enddo ! j
6611
6612         enddo ! iii
6613
6614         x(3)=x3
6615 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6616 ! subsequent NaNs and INFs in energy calculation.
6617 ! Find the largest exponent
6618         emin=contr(1,-1)
6619         do iii=-1,1
6620           do j=1,nlobit
6621             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6622           enddo
6623         enddo
6624         emin=0.5D0*emin
6625 !d      print *,'it=',it,' emin=',emin
6626
6627 ! Compute the contribution to SC energy and derivatives
6628         do iii=-1,1
6629
6630           do j=1,nlobit
6631 #ifdef OSF
6632             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6633             if(adexp.ne.adexp) adexp=1.0
6634             expfac=dexp(adexp)
6635 #else
6636             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6637 #endif
6638 !d          print *,'j=',j,' expfac=',expfac
6639             escloc_i=escloc_i+expfac
6640             do k=1,3
6641               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6642             enddo
6643             if (mixed) then
6644               do k=1,3,2
6645                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6646                   +gaussc(k,2,j,it))*expfac
6647               enddo
6648             endif
6649           enddo
6650
6651         enddo ! iii
6652
6653         dersc(1)=dersc(1)/cos(theti)**2
6654         ddersc(1)=ddersc(1)/cos(theti)**2
6655         ddersc(3)=ddersc(3)
6656
6657         escloci=-(dlog(escloc_i)-emin)
6658         do j=1,3
6659           dersc(j)=dersc(j)/escloc_i
6660         enddo
6661         if (mixed) then
6662           do j=1,3,2
6663             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6664           enddo
6665         endif
6666       return
6667       end subroutine enesc
6668 !-----------------------------------------------------------------------------
6669       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6670
6671       use comm_sccalc
6672 !      implicit real*8 (a-h,o-z)
6673 !      include 'DIMENSIONS'
6674 !      include 'COMMON.GEO'
6675 !      include 'COMMON.LOCAL'
6676 !      include 'COMMON.IOUNITS'
6677 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6678       real(kind=8),dimension(3) :: x,z,dersc
6679       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6680       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6681       real(kind=8) :: escloci,dersc12,emin
6682       logical :: mixed
6683 !el local varables
6684       integer :: j,k,l !el,it,nlobit
6685       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6686
6687       escloc_i=0.0D0
6688
6689       do j=1,3
6690         dersc(j)=0.0D0
6691       enddo
6692
6693       do j=1,nlobit
6694         do k=1,2
6695           z(k)=x(k)-censc(k,j,it)
6696         enddo
6697         z(3)=dwapi
6698         do k=1,3
6699           Axk=0.0D0
6700           do l=1,3
6701             Axk=Axk+gaussc(l,k,j,it)*z(l)
6702           enddo
6703           Ax(k,j)=Axk
6704         enddo
6705         expfac=0.0D0
6706         do k=1,3
6707           expfac=expfac+Ax(k,j)*z(k)
6708         enddo
6709         contr(j)=expfac
6710       enddo ! j
6711
6712 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6713 ! subsequent NaNs and INFs in energy calculation.
6714 ! Find the largest exponent
6715       emin=contr(1)
6716       do j=1,nlobit
6717         if (emin.gt.contr(j)) emin=contr(j)
6718       enddo
6719       emin=0.5D0*emin
6720
6721 ! Compute the contribution to SC energy and derivatives
6722
6723       dersc12=0.0d0
6724       do j=1,nlobit
6725         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6726         escloc_i=escloc_i+expfac
6727         do k=1,2
6728           dersc(k)=dersc(k)+Ax(k,j)*expfac
6729         enddo
6730         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6731                   +gaussc(1,2,j,it))*expfac
6732         dersc(3)=0.0d0
6733       enddo
6734
6735       dersc(1)=dersc(1)/cos(theti)**2
6736       dersc12=dersc12/cos(theti)**2
6737       escloci=-(dlog(escloc_i)-emin)
6738       do j=1,2
6739         dersc(j)=dersc(j)/escloc_i
6740       enddo
6741       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6742       return
6743       end subroutine enesc_bound
6744 #else
6745 !-----------------------------------------------------------------------------
6746       subroutine esc(escloc)
6747 ! Calculate the local energy of a side chain and its derivatives in the
6748 ! corresponding virtual-bond valence angles THETA and the spherical angles
6749 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6750 ! added by Urszula Kozlowska. 07/11/2007
6751 !
6752       use comm_sccalc
6753 !      implicit real*8 (a-h,o-z)
6754 !      include 'DIMENSIONS'
6755 !      include 'COMMON.GEO'
6756 !      include 'COMMON.LOCAL'
6757 !      include 'COMMON.VAR'
6758 !      include 'COMMON.SCROT'
6759 !      include 'COMMON.INTERACT'
6760 !      include 'COMMON.DERIV'
6761 !      include 'COMMON.CHAIN'
6762 !      include 'COMMON.IOUNITS'
6763 !      include 'COMMON.NAMES'
6764 !      include 'COMMON.FFIELD'
6765 !      include 'COMMON.CONTROL'
6766 !      include 'COMMON.VECTORS'
6767       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6768       real(kind=8),dimension(65) :: x
6769       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6770          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6771       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6772       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6773          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6774 !el local variables
6775       integer :: i,j,k !el,it,nlobit
6776       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6777 !el      real(kind=8) :: time11,time12,time112,theti
6778 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6779       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6780                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6781                    sumene1x,sumene2x,sumene3x,sumene4x,&
6782                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6783                    cosfac2xx,sinfac2yy
6784 #ifdef DEBUG
6785       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6786                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6787                    de_dt_num
6788 #endif
6789 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6790
6791       delta=0.02d0*pi
6792       escloc=0.0D0
6793       do i=loc_start,loc_end
6794         if (itype(i,1).eq.ntyp1) cycle
6795         costtab(i+1) =dcos(theta(i+1))
6796         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6797         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6798         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6799         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6800         cosfac=dsqrt(cosfac2)
6801         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6802         sinfac=dsqrt(sinfac2)
6803         it=iabs(itype(i,1))
6804         if (it.eq.10) goto 1
6805 !
6806 !  Compute the axes of tghe local cartesian coordinates system; store in
6807 !   x_prime, y_prime and z_prime
6808 !
6809         do j=1,3
6810           x_prime(j) = 0.00
6811           y_prime(j) = 0.00
6812           z_prime(j) = 0.00
6813         enddo
6814 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6815 !     &   dc_norm(3,i+nres)
6816         do j = 1,3
6817           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6818           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6819         enddo
6820         do j = 1,3
6821           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6822         enddo
6823 !       write (2,*) "i",i
6824 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6825 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6826 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6827 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6828 !      & " xy",scalar(x_prime(1),y_prime(1)),
6829 !      & " xz",scalar(x_prime(1),z_prime(1)),
6830 !      & " yy",scalar(y_prime(1),y_prime(1)),
6831 !      & " yz",scalar(y_prime(1),z_prime(1)),
6832 !      & " zz",scalar(z_prime(1),z_prime(1))
6833 !
6834 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6835 ! to local coordinate system. Store in xx, yy, zz.
6836 !
6837         xx=0.0d0
6838         yy=0.0d0
6839         zz=0.0d0
6840         do j = 1,3
6841           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6842           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6843           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6844         enddo
6845
6846         xxtab(i)=xx
6847         yytab(i)=yy
6848         zztab(i)=zz
6849 !
6850 ! Compute the energy of the ith side cbain
6851 !
6852 !        write (2,*) "xx",xx," yy",yy," zz",zz
6853         it=iabs(itype(i,1))
6854         do j = 1,65
6855           x(j) = sc_parmin(j,it)
6856         enddo
6857 #ifdef CHECK_COORD
6858 !c diagnostics - remove later
6859         xx1 = dcos(alph(2))
6860         yy1 = dsin(alph(2))*dcos(omeg(2))
6861         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6862         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6863           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6864           xx1,yy1,zz1
6865 !,"  --- ", xx_w,yy_w,zz_w
6866 ! end diagnostics
6867 #endif
6868         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6869          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6870          + x(10)*yy*zz
6871         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6872          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6873          + x(20)*yy*zz
6874         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6875          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6876          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6877          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6878          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6879          +x(40)*xx*yy*zz
6880         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6881          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6882          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6883          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6884          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6885          +x(60)*xx*yy*zz
6886         dsc_i   = 0.743d0+x(61)
6887         dp2_i   = 1.9d0+x(62)
6888         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6889                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6890         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6891                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6892         s1=(1+x(63))/(0.1d0 + dscp1)
6893         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6894         s2=(1+x(65))/(0.1d0 + dscp2)
6895         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6896         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6897       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6898 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6899 !     &   sumene4,
6900 !     &   dscp1,dscp2,sumene
6901 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6902         escloc = escloc + sumene
6903 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6904 !     & ,zz,xx,yy
6905 !#define DEBUG
6906 #ifdef DEBUG
6907 !
6908 ! This section to check the numerical derivatives of the energy of ith side
6909 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6910 ! #define DEBUG in the code to turn it on.
6911 !
6912         write (2,*) "sumene               =",sumene
6913         aincr=1.0d-7
6914         xxsave=xx
6915         xx=xx+aincr
6916         write (2,*) xx,yy,zz
6917         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6918         de_dxx_num=(sumenep-sumene)/aincr
6919         xx=xxsave
6920         write (2,*) "xx+ sumene from enesc=",sumenep
6921         yysave=yy
6922         yy=yy+aincr
6923         write (2,*) xx,yy,zz
6924         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6925         de_dyy_num=(sumenep-sumene)/aincr
6926         yy=yysave
6927         write (2,*) "yy+ sumene from enesc=",sumenep
6928         zzsave=zz
6929         zz=zz+aincr
6930         write (2,*) xx,yy,zz
6931         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6932         de_dzz_num=(sumenep-sumene)/aincr
6933         zz=zzsave
6934         write (2,*) "zz+ sumene from enesc=",sumenep
6935         costsave=cost2tab(i+1)
6936         sintsave=sint2tab(i+1)
6937         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6938         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6939         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6940         de_dt_num=(sumenep-sumene)/aincr
6941         write (2,*) " t+ sumene from enesc=",sumenep
6942         cost2tab(i+1)=costsave
6943         sint2tab(i+1)=sintsave
6944 ! End of diagnostics section.
6945 #endif
6946 !
6947 ! Compute the gradient of esc
6948 !
6949 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6950         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6951         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6952         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6953         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6954         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6955         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6956         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6957         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6958         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6959            *(pom_s1/dscp1+pom_s16*dscp1**4)
6960         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6961            *(pom_s2/dscp2+pom_s26*dscp2**4)
6962         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6963         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6964         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6965         +x(40)*yy*zz
6966         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6967         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6968         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6969         +x(60)*yy*zz
6970         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6971               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6972               +(pom1+pom2)*pom_dx
6973 #ifdef DEBUG
6974         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6975 #endif
6976 !
6977         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6978         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6979         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6980         +x(40)*xx*zz
6981         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6982         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6983         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6984         +x(59)*zz**2 +x(60)*xx*zz
6985         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6986               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6987               +(pom1-pom2)*pom_dy
6988 #ifdef DEBUG
6989         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6990 #endif
6991 !
6992         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6993         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6994         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6995         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6996         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6997         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6998         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6999         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7000 #ifdef DEBUG
7001         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7002 #endif
7003 !
7004         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7005         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7006         +pom1*pom_dt1+pom2*pom_dt2
7007 #ifdef DEBUG
7008         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7009 #endif
7010 !
7011 !
7012        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7013        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7014        cosfac2xx=cosfac2*xx
7015        sinfac2yy=sinfac2*yy
7016        do k = 1,3
7017          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7018             vbld_inv(i+1)
7019          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7020             vbld_inv(i)
7021          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7022          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7023 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7024 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7025 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7026 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7027          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7028          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7029          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7030          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7031          dZZ_Ci1(k)=0.0d0
7032          dZZ_Ci(k)=0.0d0
7033          do j=1,3
7034            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7035            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7036            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7037            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7038          enddo
7039
7040          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7041          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7042          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7043          (z_prime(k)-zz*dC_norm(k,i+nres))
7044 !
7045          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7046          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7047        enddo
7048
7049        do k=1,3
7050          dXX_Ctab(k,i)=dXX_Ci(k)
7051          dXX_C1tab(k,i)=dXX_Ci1(k)
7052          dYY_Ctab(k,i)=dYY_Ci(k)
7053          dYY_C1tab(k,i)=dYY_Ci1(k)
7054          dZZ_Ctab(k,i)=dZZ_Ci(k)
7055          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7056          dXX_XYZtab(k,i)=dXX_XYZ(k)
7057          dYY_XYZtab(k,i)=dYY_XYZ(k)
7058          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7059        enddo
7060
7061        do k = 1,3
7062 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7063 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7064 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7065 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7066 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7067 !     &    dt_dci(k)
7068 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7069 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7070          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7071           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7072          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7073           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7074          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7075           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7076        enddo
7077 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7078 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7079
7080 ! to check gradient call subroutine check_grad
7081
7082     1 continue
7083       enddo
7084       return
7085       end subroutine esc
7086 !-----------------------------------------------------------------------------
7087       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7088 !      implicit none
7089       real(kind=8),dimension(65) :: x
7090       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7091         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7092
7093       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7094         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7095         + x(10)*yy*zz
7096       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7097         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7098         + x(20)*yy*zz
7099       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7100         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7101         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7102         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7103         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7104         +x(40)*xx*yy*zz
7105       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7106         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7107         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7108         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7109         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7110         +x(60)*xx*yy*zz
7111       dsc_i   = 0.743d0+x(61)
7112       dp2_i   = 1.9d0+x(62)
7113       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7114                 *(xx*cost2+yy*sint2))
7115       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7116                 *(xx*cost2-yy*sint2))
7117       s1=(1+x(63))/(0.1d0 + dscp1)
7118       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7119       s2=(1+x(65))/(0.1d0 + dscp2)
7120       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7121       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7122        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7123       enesc=sumene
7124       return
7125       end function enesc
7126 #endif
7127 !-----------------------------------------------------------------------------
7128       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7129 !
7130 ! This procedure calculates two-body contact function g(rij) and its derivative:
7131 !
7132 !           eps0ij                                     !       x < -1
7133 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7134 !            0                                         !       x > 1
7135 !
7136 ! where x=(rij-r0ij)/delta
7137 !
7138 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7139 !
7140 !      implicit none
7141       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7142       real(kind=8) :: x,x2,x4,delta
7143 !     delta=0.02D0*r0ij
7144 !      delta=0.2D0*r0ij
7145       x=(rij-r0ij)/delta
7146       if (x.lt.-1.0D0) then
7147         fcont=eps0ij
7148         fprimcont=0.0D0
7149       else if (x.le.1.0D0) then
7150         x2=x*x
7151         x4=x2*x2
7152         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7153         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7154       else
7155         fcont=0.0D0
7156         fprimcont=0.0D0
7157       endif
7158       return
7159       end subroutine gcont
7160 !-----------------------------------------------------------------------------
7161       subroutine splinthet(theti,delta,ss,ssder)
7162 !      implicit real*8 (a-h,o-z)
7163 !      include 'DIMENSIONS'
7164 !      include 'COMMON.VAR'
7165 !      include 'COMMON.GEO'
7166       real(kind=8) :: theti,delta,ss,ssder
7167       real(kind=8) :: thetup,thetlow
7168       thetup=pi-delta
7169       thetlow=delta
7170       if (theti.gt.pipol) then
7171         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7172       else
7173         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7174         ssder=-ssder
7175       endif
7176       return
7177       end subroutine splinthet
7178 !-----------------------------------------------------------------------------
7179       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7180 !      implicit none
7181       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7182       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7183       a1=fprim0*delta/(f1-f0)
7184       a2=3.0d0-2.0d0*a1
7185       a3=a1-2.0d0
7186       ksi=(x-x0)/delta
7187       ksi2=ksi*ksi
7188       ksi3=ksi2*ksi
7189       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7190       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7191       return
7192       end subroutine spline1
7193 !-----------------------------------------------------------------------------
7194       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7195 !      implicit none
7196       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7197       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7198       ksi=(x-x0)/delta
7199       ksi2=ksi*ksi
7200       ksi3=ksi2*ksi
7201       a1=fprim0x*delta
7202       a2=3*(f1x-f0x)-2*fprim0x*delta
7203       a3=fprim0x*delta-2*(f1x-f0x)
7204       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7205       return
7206       end subroutine spline2
7207 !-----------------------------------------------------------------------------
7208 #ifdef CRYST_TOR
7209 !-----------------------------------------------------------------------------
7210       subroutine etor(etors,edihcnstr)
7211 !      implicit real*8 (a-h,o-z)
7212 !      include 'DIMENSIONS'
7213 !      include 'COMMON.VAR'
7214 !      include 'COMMON.GEO'
7215 !      include 'COMMON.LOCAL'
7216 !      include 'COMMON.TORSION'
7217 !      include 'COMMON.INTERACT'
7218 !      include 'COMMON.DERIV'
7219 !      include 'COMMON.CHAIN'
7220 !      include 'COMMON.NAMES'
7221 !      include 'COMMON.IOUNITS'
7222 !      include 'COMMON.FFIELD'
7223 !      include 'COMMON.TORCNSTR'
7224 !      include 'COMMON.CONTROL'
7225       real(kind=8) :: etors,edihcnstr
7226       logical :: lprn
7227 !el local variables
7228       integer :: i,j,
7229       real(kind=8) :: phii,fac,etors_ii
7230
7231 ! Set lprn=.true. for debugging
7232       lprn=.false.
7233 !      lprn=.true.
7234       etors=0.0D0
7235       do i=iphi_start,iphi_end
7236       etors_ii=0.0D0
7237         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7238             .or. itype(i,1).eq.ntyp1) cycle
7239         itori=itortyp(itype(i-2,1))
7240         itori1=itortyp(itype(i-1,1))
7241         phii=phi(i)
7242         gloci=0.0D0
7243 ! Proline-Proline pair is a special case...
7244         if (itori.eq.3 .and. itori1.eq.3) then
7245           if (phii.gt.-dwapi3) then
7246             cosphi=dcos(3*phii)
7247             fac=1.0D0/(1.0D0-cosphi)
7248             etorsi=v1(1,3,3)*fac
7249             etorsi=etorsi+etorsi
7250             etors=etors+etorsi-v1(1,3,3)
7251             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7252             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7253           endif
7254           do j=1,3
7255             v1ij=v1(j+1,itori,itori1)
7256             v2ij=v2(j+1,itori,itori1)
7257             cosphi=dcos(j*phii)
7258             sinphi=dsin(j*phii)
7259             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7260             if (energy_dec) etors_ii=etors_ii+ &
7261                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7262             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7263           enddo
7264         else
7265           do j=1,nterm_old
7266             v1ij=v1(j,itori,itori1)
7267             v2ij=v2(j,itori,itori1)
7268             cosphi=dcos(j*phii)
7269             sinphi=dsin(j*phii)
7270             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7271             if (energy_dec) etors_ii=etors_ii+ &
7272                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7273             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7274           enddo
7275         endif
7276         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7277              'etor',i,etors_ii
7278         if (lprn) &
7279         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7280         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7281         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7282         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7283 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7284       enddo
7285 ! 6/20/98 - dihedral angle constraints
7286       edihcnstr=0.0d0
7287       do i=1,ndih_constr
7288         itori=idih_constr(i)
7289         phii=phi(itori)
7290         difi=phii-phi0(i)
7291         if (difi.gt.drange(i)) then
7292           difi=difi-drange(i)
7293           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7294           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7295         else if (difi.lt.-drange(i)) then
7296           difi=difi+drange(i)
7297           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7298           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7299         endif
7300 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7301 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7302       enddo
7303 !      write (iout,*) 'edihcnstr',edihcnstr
7304       return
7305       end subroutine etor
7306 !-----------------------------------------------------------------------------
7307       subroutine etor_d(etors_d)
7308       real(kind=8) :: etors_d
7309       etors_d=0.0d0
7310       return
7311       end subroutine etor_d
7312 #else
7313 !-----------------------------------------------------------------------------
7314       subroutine etor(etors)
7315 !      implicit real*8 (a-h,o-z)
7316 !      include 'DIMENSIONS'
7317 !      include 'COMMON.VAR'
7318 !      include 'COMMON.GEO'
7319 !      include 'COMMON.LOCAL'
7320 !      include 'COMMON.TORSION'
7321 !      include 'COMMON.INTERACT'
7322 !      include 'COMMON.DERIV'
7323 !      include 'COMMON.CHAIN'
7324 !      include 'COMMON.NAMES'
7325 !      include 'COMMON.IOUNITS'
7326 !      include 'COMMON.FFIELD'
7327 !      include 'COMMON.TORCNSTR'
7328 !      include 'COMMON.CONTROL'
7329       real(kind=8) :: etors,edihcnstr
7330       logical :: lprn
7331 !el local variables
7332       integer :: i,j,iblock,itori,itori1
7333       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7334                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7335 ! Set lprn=.true. for debugging
7336       lprn=.false.
7337 !     lprn=.true.
7338       etors=0.0D0
7339       do i=iphi_start,iphi_end
7340         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7341              .or. itype(i-3,1).eq.ntyp1 &
7342              .or. itype(i,1).eq.ntyp1) cycle
7343         etors_ii=0.0D0
7344          if (iabs(itype(i,1)).eq.20) then
7345          iblock=2
7346          else
7347          iblock=1
7348          endif
7349         itori=itortyp(itype(i-2,1))
7350         itori1=itortyp(itype(i-1,1))
7351         phii=phi(i)
7352         gloci=0.0D0
7353 ! Regular cosine and sine terms
7354         do j=1,nterm(itori,itori1,iblock)
7355           v1ij=v1(j,itori,itori1,iblock)
7356           v2ij=v2(j,itori,itori1,iblock)
7357           cosphi=dcos(j*phii)
7358           sinphi=dsin(j*phii)
7359           etors=etors+v1ij*cosphi+v2ij*sinphi
7360           if (energy_dec) etors_ii=etors_ii+ &
7361                      v1ij*cosphi+v2ij*sinphi
7362           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7363         enddo
7364 ! Lorentz terms
7365 !                         v1
7366 !  E = SUM ----------------------------------- - v1
7367 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7368 !
7369         cosphi=dcos(0.5d0*phii)
7370         sinphi=dsin(0.5d0*phii)
7371         do j=1,nlor(itori,itori1,iblock)
7372           vl1ij=vlor1(j,itori,itori1)
7373           vl2ij=vlor2(j,itori,itori1)
7374           vl3ij=vlor3(j,itori,itori1)
7375           pom=vl2ij*cosphi+vl3ij*sinphi
7376           pom1=1.0d0/(pom*pom+1.0d0)
7377           etors=etors+vl1ij*pom1
7378           if (energy_dec) etors_ii=etors_ii+ &
7379                      vl1ij*pom1
7380           pom=-pom*pom1*pom1
7381           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7382         enddo
7383 ! Subtract the constant term
7384         etors=etors-v0(itori,itori1,iblock)
7385           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7386                'etor',i,etors_ii-v0(itori,itori1,iblock)
7387         if (lprn) &
7388         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7389         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7390         (v1(j,itori,itori1,iblock),j=1,6),&
7391         (v2(j,itori,itori1,iblock),j=1,6)
7392         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7393 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7394       enddo
7395 ! 6/20/98 - dihedral angle constraints
7396       return
7397       end subroutine etor
7398 !C The rigorous attempt to derive energy function
7399 !-------------------------------------------------------------------------------------------
7400       subroutine etor_kcc(etors)
7401       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7402       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7403        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7404        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7405        gradvalst2,etori
7406       logical lprn
7407       integer :: i,j,itori,itori1,nval,k,l
7408
7409       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7410       etors=0.0D0
7411       do i=iphi_start,iphi_end
7412 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7413 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7414 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7415 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7416         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7417            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7418         itori=itortyp(itype(i-2,1))
7419         itori1=itortyp(itype(i-1,1))
7420         phii=phi(i)
7421         glocig=0.0D0
7422         glocit1=0.0d0
7423         glocit2=0.0d0
7424 !C to avoid multiple devision by 2
7425 !c        theti22=0.5d0*theta(i)
7426 !C theta 12 is the theta_1 /2
7427 !C theta 22 is theta_2 /2
7428 !c        theti12=0.5d0*theta(i-1)
7429 !C and appropriate sinus function
7430         sinthet1=dsin(theta(i-1))
7431         sinthet2=dsin(theta(i))
7432         costhet1=dcos(theta(i-1))
7433         costhet2=dcos(theta(i))
7434 !C to speed up lets store its mutliplication
7435         sint1t2=sinthet2*sinthet1
7436         sint1t2n=1.0d0
7437 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7438 !C +d_n*sin(n*gamma)) *
7439 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7440 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7441         nval=nterm_kcc_Tb(itori,itori1)
7442         c1(0)=0.0d0
7443         c2(0)=0.0d0
7444         c1(1)=1.0d0
7445         c2(1)=1.0d0
7446         do j=2,nval
7447           c1(j)=c1(j-1)*costhet1
7448           c2(j)=c2(j-1)*costhet2
7449         enddo
7450         etori=0.0d0
7451
7452        do j=1,nterm_kcc(itori,itori1)
7453           cosphi=dcos(j*phii)
7454           sinphi=dsin(j*phii)
7455           sint1t2n1=sint1t2n
7456           sint1t2n=sint1t2n*sint1t2
7457           sumvalc=0.0d0
7458           gradvalct1=0.0d0
7459           gradvalct2=0.0d0
7460           do k=1,nval
7461             do l=1,nval
7462               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7463               gradvalct1=gradvalct1+ &
7464                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7465               gradvalct2=gradvalct2+ &
7466                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7467             enddo
7468           enddo
7469           gradvalct1=-gradvalct1*sinthet1
7470           gradvalct2=-gradvalct2*sinthet2
7471           sumvals=0.0d0
7472           gradvalst1=0.0d0
7473           gradvalst2=0.0d0
7474           do k=1,nval
7475             do l=1,nval
7476               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7477               gradvalst1=gradvalst1+ &
7478                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7479               gradvalst2=gradvalst2+ &
7480                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7481             enddo
7482           enddo
7483           gradvalst1=-gradvalst1*sinthet1
7484           gradvalst2=-gradvalst2*sinthet2
7485           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7486           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7487 !C glocig is the gradient local i site in gamma
7488           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7489 !C now gradient over theta_1
7490          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7491         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7492          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7493         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7494         enddo ! j
7495         etors=etors+etori
7496         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7497 !C derivative over theta1
7498         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7499 !C now derivative over theta2
7500         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7501         if (lprn) then
7502          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7503             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7504           write (iout,*) "c1",(c1(k),k=0,nval), &
7505          " c2",(c2(k),k=0,nval)
7506         endif
7507       enddo
7508       return
7509        end  subroutine etor_kcc
7510 !------------------------------------------------------------------------------
7511
7512         subroutine etor_constr(edihcnstr)
7513       real(kind=8) :: etors,edihcnstr
7514       logical :: lprn
7515 !el local variables
7516       integer :: i,j,iblock,itori,itori1
7517       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7518                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7519                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7520
7521       if (raw_psipred) then
7522         do i=idihconstr_start,idihconstr_end
7523           itori=idih_constr(i)
7524           phii=phi(itori)
7525           gaudih_i=vpsipred(1,i)
7526           gauder_i=0.0d0
7527           do j=1,2
7528             s = sdihed(j,i)
7529             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7530             dexpcos_i=dexp(-cos_i*cos_i)
7531             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7532           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7533                  *cos_i*dexpcos_i/s**2
7534           enddo
7535           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7536           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7537           if (energy_dec) &
7538           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7539           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7540           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7541           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7542           -wdihc*dlog(gaudih_i)
7543         enddo
7544       else
7545
7546       do i=idihconstr_start,idihconstr_end
7547         itori=idih_constr(i)
7548         phii=phi(itori)
7549         difi=pinorm(phii-phi0(i))
7550         if (difi.gt.drange(i)) then
7551           difi=difi-drange(i)
7552           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7553           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7554         else if (difi.lt.-drange(i)) then
7555           difi=difi+drange(i)
7556           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7557           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7558         else
7559           difi=0.0
7560         endif
7561       enddo
7562
7563       endif
7564
7565       return
7566
7567       end subroutine etor_constr
7568 !-----------------------------------------------------------------------------
7569       subroutine etor_d(etors_d)
7570 ! 6/23/01 Compute double torsional energy
7571 !      implicit real*8 (a-h,o-z)
7572 !      include 'DIMENSIONS'
7573 !      include 'COMMON.VAR'
7574 !      include 'COMMON.GEO'
7575 !      include 'COMMON.LOCAL'
7576 !      include 'COMMON.TORSION'
7577 !      include 'COMMON.INTERACT'
7578 !      include 'COMMON.DERIV'
7579 !      include 'COMMON.CHAIN'
7580 !      include 'COMMON.NAMES'
7581 !      include 'COMMON.IOUNITS'
7582 !      include 'COMMON.FFIELD'
7583 !      include 'COMMON.TORCNSTR'
7584       real(kind=8) :: etors_d,etors_d_ii
7585       logical :: lprn
7586 !el local variables
7587       integer :: i,j,k,l,itori,itori1,itori2,iblock
7588       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7589                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7590                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7591                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7592 ! Set lprn=.true. for debugging
7593       lprn=.false.
7594 !     lprn=.true.
7595       etors_d=0.0D0
7596 !      write(iout,*) "a tu??"
7597       do i=iphid_start,iphid_end
7598         etors_d_ii=0.0D0
7599         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7600             .or. itype(i-3,1).eq.ntyp1 &
7601             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7602         itori=itortyp(itype(i-2,1))
7603         itori1=itortyp(itype(i-1,1))
7604         itori2=itortyp(itype(i,1))
7605         phii=phi(i)
7606         phii1=phi(i+1)
7607         gloci1=0.0D0
7608         gloci2=0.0D0
7609         iblock=1
7610         if (iabs(itype(i+1,1)).eq.20) iblock=2
7611
7612 ! Regular cosine and sine terms
7613         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7614           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7615           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7616           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7617           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7618           cosphi1=dcos(j*phii)
7619           sinphi1=dsin(j*phii)
7620           cosphi2=dcos(j*phii1)
7621           sinphi2=dsin(j*phii1)
7622           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7623            v2cij*cosphi2+v2sij*sinphi2
7624           if (energy_dec) etors_d_ii=etors_d_ii+ &
7625            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7626           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7627           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7628         enddo
7629         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7630           do l=1,k-1
7631             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7632             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7633             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7634             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7635             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7636             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7637             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7638             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7639             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7640               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7641             if (energy_dec) etors_d_ii=etors_d_ii+ &
7642               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7643               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7644             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7645               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7646             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7647               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7648           enddo
7649         enddo
7650         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7651                             'etor_d',i,etors_d_ii
7652         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7653         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7654       enddo
7655       return
7656       end subroutine etor_d
7657 #endif
7658
7659       subroutine ebend_kcc(etheta)
7660       logical lprn
7661       double precision thybt1(maxang_kcc),etheta
7662       integer :: i,iti,j,ihelp
7663       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7664 !C Set lprn=.true. for debugging
7665       lprn=energy_dec
7666 !c     lprn=.true.
7667 !C      print *,"wchodze kcc"
7668       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7669       etheta=0.0D0
7670       do i=ithet_start,ithet_end
7671 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7672         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7673        .or.itype(i,1).eq.ntyp1) cycle
7674         iti=iabs(itortyp(itype(i-1,1)))
7675         sinthet=dsin(theta(i))
7676         costhet=dcos(theta(i))
7677         do j=1,nbend_kcc_Tb(iti)
7678           thybt1(j)=v1bend_chyb(j,iti)
7679         enddo
7680         sumth1thyb=v1bend_chyb(0,iti)+ &
7681          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7682         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7683          sumth1thyb
7684         ihelp=nbend_kcc_Tb(iti)-1
7685         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7686         etheta=etheta+sumth1thyb
7687 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7688         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7689       enddo
7690       return
7691       end subroutine ebend_kcc
7692 !c------------
7693 !c-------------------------------------------------------------------------------------
7694       subroutine etheta_constr(ethetacnstr)
7695       real (kind=8) :: ethetacnstr,thetiii,difi
7696       integer :: i,itheta
7697       ethetacnstr=0.0d0
7698 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7699       do i=ithetaconstr_start,ithetaconstr_end
7700         itheta=itheta_constr(i)
7701         thetiii=theta(itheta)
7702         difi=pinorm(thetiii-theta_constr0(i))
7703         if (difi.gt.theta_drange(i)) then
7704           difi=difi-theta_drange(i)
7705           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7706           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7707          +for_thet_constr(i)*difi**3
7708         else if (difi.lt.-drange(i)) then
7709           difi=difi+drange(i)
7710           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7711           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7712           +for_thet_constr(i)*difi**3
7713         else
7714           difi=0.0
7715         endif
7716        if (energy_dec) then
7717         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7718          i,itheta,rad2deg*thetiii,&
7719          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7720          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7721          gloc(itheta+nphi-2,icg)
7722         endif
7723       enddo
7724       return
7725       end subroutine etheta_constr
7726
7727 !-----------------------------------------------------------------------------
7728       subroutine eback_sc_corr(esccor)
7729 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7730 !        conformational states; temporarily implemented as differences
7731 !        between UNRES torsional potentials (dependent on three types of
7732 !        residues) and the torsional potentials dependent on all 20 types
7733 !        of residues computed from AM1  energy surfaces of terminally-blocked
7734 !        amino-acid residues.
7735 !      implicit real*8 (a-h,o-z)
7736 !      include 'DIMENSIONS'
7737 !      include 'COMMON.VAR'
7738 !      include 'COMMON.GEO'
7739 !      include 'COMMON.LOCAL'
7740 !      include 'COMMON.TORSION'
7741 !      include 'COMMON.SCCOR'
7742 !      include 'COMMON.INTERACT'
7743 !      include 'COMMON.DERIV'
7744 !      include 'COMMON.CHAIN'
7745 !      include 'COMMON.NAMES'
7746 !      include 'COMMON.IOUNITS'
7747 !      include 'COMMON.FFIELD'
7748 !      include 'COMMON.CONTROL'
7749       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7750                    cosphi,sinphi
7751       logical :: lprn
7752       integer :: i,interty,j,isccori,isccori1,intertyp
7753 ! Set lprn=.true. for debugging
7754       lprn=.false.
7755 !      lprn=.true.
7756 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7757       esccor=0.0D0
7758       do i=itau_start,itau_end
7759         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7760         esccor_ii=0.0D0
7761         isccori=isccortyp(itype(i-2,1))
7762         isccori1=isccortyp(itype(i-1,1))
7763
7764 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7765         phii=phi(i)
7766         do intertyp=1,3 !intertyp
7767          esccor_ii=0.0D0
7768 !c Added 09 May 2012 (Adasko)
7769 !c  Intertyp means interaction type of backbone mainchain correlation:
7770 !   1 = SC...Ca...Ca...Ca
7771 !   2 = Ca...Ca...Ca...SC
7772 !   3 = SC...Ca...Ca...SCi
7773         gloci=0.0D0
7774         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7775             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7776             (itype(i-1,1).eq.ntyp1))) &
7777           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7778            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7779            .or.(itype(i,1).eq.ntyp1))) &
7780           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7781             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7782             (itype(i-3,1).eq.ntyp1)))) cycle
7783         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7784         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7785        cycle
7786        do j=1,nterm_sccor(isccori,isccori1)
7787           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7788           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7789           cosphi=dcos(j*tauangle(intertyp,i))
7790           sinphi=dsin(j*tauangle(intertyp,i))
7791           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7792           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7793           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7794         enddo
7795         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7796                                 'esccor',i,intertyp,esccor_ii
7797 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7798         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7799         if (lprn) &
7800         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7801         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7802         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7803         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7804         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7805        enddo !intertyp
7806       enddo
7807
7808       return
7809       end subroutine eback_sc_corr
7810 !-----------------------------------------------------------------------------
7811       subroutine multibody(ecorr)
7812 ! This subroutine calculates multi-body contributions to energy following
7813 ! the idea of Skolnick et al. If side chains I and J make a contact and
7814 ! at the same time side chains I+1 and J+1 make a contact, an extra
7815 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7816 !      implicit real*8 (a-h,o-z)
7817 !      include 'DIMENSIONS'
7818 !      include 'COMMON.IOUNITS'
7819 !      include 'COMMON.DERIV'
7820 !      include 'COMMON.INTERACT'
7821 !      include 'COMMON.CONTACTS'
7822       real(kind=8),dimension(3) :: gx,gx1
7823       logical :: lprn
7824       real(kind=8) :: ecorr
7825       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7826 ! Set lprn=.true. for debugging
7827       lprn=.false.
7828
7829       if (lprn) then
7830         write (iout,'(a)') 'Contact function values:'
7831         do i=nnt,nct-2
7832           write (iout,'(i2,20(1x,i2,f10.5))') &
7833               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7834         enddo
7835       endif
7836       ecorr=0.0D0
7837
7838 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7839 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7840       do i=nnt,nct
7841         do j=1,3
7842           gradcorr(j,i)=0.0D0
7843           gradxorr(j,i)=0.0D0
7844         enddo
7845       enddo
7846       do i=nnt,nct-2
7847
7848         DO ISHIFT = 3,4
7849
7850         i1=i+ishift
7851         num_conti=num_cont(i)
7852         num_conti1=num_cont(i1)
7853         do jj=1,num_conti
7854           j=jcont(jj,i)
7855           do kk=1,num_conti1
7856             j1=jcont(kk,i1)
7857             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7858 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7859 !d   &                   ' ishift=',ishift
7860 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7861 ! The system gains extra energy.
7862               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7863             endif   ! j1==j+-ishift
7864           enddo     ! kk
7865         enddo       ! jj
7866
7867         ENDDO ! ISHIFT
7868
7869       enddo         ! i
7870       return
7871       end subroutine multibody
7872 !-----------------------------------------------------------------------------
7873       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7874 !      implicit real*8 (a-h,o-z)
7875 !      include 'DIMENSIONS'
7876 !      include 'COMMON.IOUNITS'
7877 !      include 'COMMON.DERIV'
7878 !      include 'COMMON.INTERACT'
7879 !      include 'COMMON.CONTACTS'
7880       real(kind=8),dimension(3) :: gx,gx1
7881       logical :: lprn
7882       integer :: i,j,k,l,jj,kk,m,ll
7883       real(kind=8) :: eij,ekl
7884       lprn=.false.
7885       eij=facont(jj,i)
7886       ekl=facont(kk,k)
7887 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7888 ! Calculate the multi-body contribution to energy.
7889 ! Calculate multi-body contributions to the gradient.
7890 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7891 !d   & k,l,(gacont(m,kk,k),m=1,3)
7892       do m=1,3
7893         gx(m) =ekl*gacont(m,jj,i)
7894         gx1(m)=eij*gacont(m,kk,k)
7895         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7896         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7897         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7898         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7899       enddo
7900       do m=i,j-1
7901         do ll=1,3
7902           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7903         enddo
7904       enddo
7905       do m=k,l-1
7906         do ll=1,3
7907           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7908         enddo
7909       enddo
7910       esccorr=-eij*ekl
7911       return
7912       end function esccorr
7913 !-----------------------------------------------------------------------------
7914       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7915 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7916 !      implicit real*8 (a-h,o-z)
7917 !      include 'DIMENSIONS'
7918 !      include 'COMMON.IOUNITS'
7919 #ifdef MPI
7920       include "mpif.h"
7921 !      integer :: maxconts !max_cont=maxconts  =nres/4
7922       integer,parameter :: max_dim=26
7923       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7924       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7925 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7926 !el      common /przechowalnia/ zapas
7927       integer :: status(MPI_STATUS_SIZE)
7928       integer,dimension((nres/4)*2) :: req !maxconts*2
7929       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7930 #endif
7931 !      include 'COMMON.SETUP'
7932 !      include 'COMMON.FFIELD'
7933 !      include 'COMMON.DERIV'
7934 !      include 'COMMON.INTERACT'
7935 !      include 'COMMON.CONTACTS'
7936 !      include 'COMMON.CONTROL'
7937 !      include 'COMMON.LOCAL'
7938       real(kind=8),dimension(3) :: gx,gx1
7939       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7940       logical :: lprn,ldone
7941 !el local variables
7942       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7943               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7944
7945 ! Set lprn=.true. for debugging
7946       lprn=.false.
7947 #ifdef MPI
7948 !      maxconts=nres/4
7949       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7950       n_corr=0
7951       n_corr1=0
7952       if (nfgtasks.le.1) goto 30
7953       if (lprn) then
7954         write (iout,'(a)') 'Contact function values before RECEIVE:'
7955         do i=nnt,nct-2
7956           write (iout,'(2i3,50(1x,i2,f5.2))') &
7957           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7958           j=1,num_cont_hb(i))
7959         enddo
7960       endif
7961       call flush(iout)
7962       do i=1,ntask_cont_from
7963         ncont_recv(i)=0
7964       enddo
7965       do i=1,ntask_cont_to
7966         ncont_sent(i)=0
7967       enddo
7968 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7969 !     & ntask_cont_to
7970 ! Make the list of contacts to send to send to other procesors
7971 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7972 !      call flush(iout)
7973       do i=iturn3_start,iturn3_end
7974 !        write (iout,*) "make contact list turn3",i," num_cont",
7975 !     &    num_cont_hb(i)
7976         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7977       enddo
7978       do i=iturn4_start,iturn4_end
7979 !        write (iout,*) "make contact list turn4",i," num_cont",
7980 !     &   num_cont_hb(i)
7981         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7982       enddo
7983       do ii=1,nat_sent
7984         i=iat_sent(ii)
7985 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7986 !     &    num_cont_hb(i)
7987         do j=1,num_cont_hb(i)
7988         do k=1,4
7989           jjc=jcont_hb(j,i)
7990           iproc=iint_sent_local(k,jjc,ii)
7991 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7992           if (iproc.gt.0) then
7993             ncont_sent(iproc)=ncont_sent(iproc)+1
7994             nn=ncont_sent(iproc)
7995             zapas(1,nn,iproc)=i
7996             zapas(2,nn,iproc)=jjc
7997             zapas(3,nn,iproc)=facont_hb(j,i)
7998             zapas(4,nn,iproc)=ees0p(j,i)
7999             zapas(5,nn,iproc)=ees0m(j,i)
8000             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8001             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8002             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8003             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8004             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8005             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8006             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8007             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8008             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8009             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8010             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8011             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8012             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8013             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8014             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8015             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8016             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8017             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8018             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8019             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8020             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8021           endif
8022         enddo
8023         enddo
8024       enddo
8025       if (lprn) then
8026       write (iout,*) &
8027         "Numbers of contacts to be sent to other processors",&
8028         (ncont_sent(i),i=1,ntask_cont_to)
8029       write (iout,*) "Contacts sent"
8030       do ii=1,ntask_cont_to
8031         nn=ncont_sent(ii)
8032         iproc=itask_cont_to(ii)
8033         write (iout,*) nn," contacts to processor",iproc,&
8034          " of CONT_TO_COMM group"
8035         do i=1,nn
8036           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8037         enddo
8038       enddo
8039       call flush(iout)
8040       endif
8041       CorrelType=477
8042       CorrelID=fg_rank+1
8043       CorrelType1=478
8044       CorrelID1=nfgtasks+fg_rank+1
8045       ireq=0
8046 ! Receive the numbers of needed contacts from other processors
8047       do ii=1,ntask_cont_from
8048         iproc=itask_cont_from(ii)
8049         ireq=ireq+1
8050         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8051           FG_COMM,req(ireq),IERR)
8052       enddo
8053 !      write (iout,*) "IRECV ended"
8054 !      call flush(iout)
8055 ! Send the number of contacts needed by other processors
8056       do ii=1,ntask_cont_to
8057         iproc=itask_cont_to(ii)
8058         ireq=ireq+1
8059         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8060           FG_COMM,req(ireq),IERR)
8061       enddo
8062 !      write (iout,*) "ISEND ended"
8063 !      write (iout,*) "number of requests (nn)",ireq
8064       call flush(iout)
8065       if (ireq.gt.0) &
8066         call MPI_Waitall(ireq,req,status_array,ierr)
8067 !      write (iout,*)
8068 !     &  "Numbers of contacts to be received from other processors",
8069 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8070 !      call flush(iout)
8071 ! Receive contacts
8072       ireq=0
8073       do ii=1,ntask_cont_from
8074         iproc=itask_cont_from(ii)
8075         nn=ncont_recv(ii)
8076 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8077 !     &   " of CONT_TO_COMM group"
8078         call flush(iout)
8079         if (nn.gt.0) then
8080           ireq=ireq+1
8081           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8082           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8083 !          write (iout,*) "ireq,req",ireq,req(ireq)
8084         endif
8085       enddo
8086 ! Send the contacts to processors that need them
8087       do ii=1,ntask_cont_to
8088         iproc=itask_cont_to(ii)
8089         nn=ncont_sent(ii)
8090 !        write (iout,*) nn," contacts to processor",iproc,
8091 !     &   " of CONT_TO_COMM group"
8092         if (nn.gt.0) then
8093           ireq=ireq+1
8094           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8095             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8096 !          write (iout,*) "ireq,req",ireq,req(ireq)
8097 !          do i=1,nn
8098 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8099 !          enddo
8100         endif
8101       enddo
8102 !      write (iout,*) "number of requests (contacts)",ireq
8103 !      write (iout,*) "req",(req(i),i=1,4)
8104 !      call flush(iout)
8105       if (ireq.gt.0) &
8106        call MPI_Waitall(ireq,req,status_array,ierr)
8107       do iii=1,ntask_cont_from
8108         iproc=itask_cont_from(iii)
8109         nn=ncont_recv(iii)
8110         if (lprn) then
8111         write (iout,*) "Received",nn," contacts from processor",iproc,&
8112          " of CONT_FROM_COMM group"
8113         call flush(iout)
8114         do i=1,nn
8115           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8116         enddo
8117         call flush(iout)
8118         endif
8119         do i=1,nn
8120           ii=zapas_recv(1,i,iii)
8121 ! Flag the received contacts to prevent double-counting
8122           jj=-zapas_recv(2,i,iii)
8123 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8124 !          call flush(iout)
8125           nnn=num_cont_hb(ii)+1
8126           num_cont_hb(ii)=nnn
8127           jcont_hb(nnn,ii)=jj
8128           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8129           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8130           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8131           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8132           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8133           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8134           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8135           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8136           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8137           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8138           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8139           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8140           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8141           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8142           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8143           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8144           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8145           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8146           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8147           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8148           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8149           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8150           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8151           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8152         enddo
8153       enddo
8154       call flush(iout)
8155       if (lprn) then
8156         write (iout,'(a)') 'Contact function values after receive:'
8157         do i=nnt,nct-2
8158           write (iout,'(2i3,50(1x,i3,f5.2))') &
8159           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8160           j=1,num_cont_hb(i))
8161         enddo
8162         call flush(iout)
8163       endif
8164    30 continue
8165 #endif
8166       if (lprn) then
8167         write (iout,'(a)') 'Contact function values:'
8168         do i=nnt,nct-2
8169           write (iout,'(2i3,50(1x,i3,f5.2))') &
8170           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8171           j=1,num_cont_hb(i))
8172         enddo
8173       endif
8174       ecorr=0.0D0
8175
8176 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8177 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8178 ! Remove the loop below after debugging !!!
8179       do i=nnt,nct
8180         do j=1,3
8181           gradcorr(j,i)=0.0D0
8182           gradxorr(j,i)=0.0D0
8183         enddo
8184       enddo
8185 ! Calculate the local-electrostatic correlation terms
8186       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8187         i1=i+1
8188         num_conti=num_cont_hb(i)
8189         num_conti1=num_cont_hb(i+1)
8190         do jj=1,num_conti
8191           j=jcont_hb(jj,i)
8192           jp=iabs(j)
8193           do kk=1,num_conti1
8194             j1=jcont_hb(kk,i1)
8195             jp1=iabs(j1)
8196 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8197 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8198             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8199                 .or. j.lt.0 .and. j1.gt.0) .and. &
8200                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8201 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8202 ! The system gains extra energy.
8203               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8204               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8205                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8206               n_corr=n_corr+1
8207             else if (j1.eq.j) then
8208 ! Contacts I-J and I-(J+1) occur simultaneously.
8209 ! The system loses extra energy.
8210 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8211             endif
8212           enddo ! kk
8213           do kk=1,num_conti
8214             j1=jcont_hb(kk,i)
8215 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8216 !    &         ' jj=',jj,' kk=',kk
8217             if (j1.eq.j+1) then
8218 ! Contacts I-J and (I+1)-J occur simultaneously.
8219 ! The system loses extra energy.
8220 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8221             endif ! j1==j+1
8222           enddo ! kk
8223         enddo ! jj
8224       enddo ! i
8225       return
8226       end subroutine multibody_hb
8227 !-----------------------------------------------------------------------------
8228       subroutine add_hb_contact(ii,jj,itask)
8229 !      implicit real*8 (a-h,o-z)
8230 !      include "DIMENSIONS"
8231 !      include "COMMON.IOUNITS"
8232 !      include "COMMON.CONTACTS"
8233 !      integer,parameter :: maxconts=nres/4
8234       integer,parameter :: max_dim=26
8235       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8236 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8237 !      common /przechowalnia/ zapas
8238       integer :: i,j,ii,jj,iproc,nn,jjc
8239       integer,dimension(4) :: itask
8240 !      write (iout,*) "itask",itask
8241       do i=1,2
8242         iproc=itask(i)
8243         if (iproc.gt.0) then
8244           do j=1,num_cont_hb(ii)
8245             jjc=jcont_hb(j,ii)
8246 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8247             if (jjc.eq.jj) then
8248               ncont_sent(iproc)=ncont_sent(iproc)+1
8249               nn=ncont_sent(iproc)
8250               zapas(1,nn,iproc)=ii
8251               zapas(2,nn,iproc)=jjc
8252               zapas(3,nn,iproc)=facont_hb(j,ii)
8253               zapas(4,nn,iproc)=ees0p(j,ii)
8254               zapas(5,nn,iproc)=ees0m(j,ii)
8255               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8256               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8257               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8258               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8259               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8260               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8261               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8262               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8263               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8264               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8265               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8266               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8267               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8268               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8269               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8270               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8271               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8272               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8273               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8274               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8275               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8276               exit
8277             endif
8278           enddo
8279         endif
8280       enddo
8281       return
8282       end subroutine add_hb_contact
8283 !-----------------------------------------------------------------------------
8284       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8285 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8286 !      implicit real*8 (a-h,o-z)
8287 !      include 'DIMENSIONS'
8288 !      include 'COMMON.IOUNITS'
8289       integer,parameter :: max_dim=70
8290 #ifdef MPI
8291       include "mpif.h"
8292 !      integer :: maxconts !max_cont=maxconts=nres/4
8293       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8294       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8295 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8296 !      common /przechowalnia/ zapas
8297       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8298         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8299         ierr,iii,nnn
8300 #endif
8301 !      include 'COMMON.SETUP'
8302 !      include 'COMMON.FFIELD'
8303 !      include 'COMMON.DERIV'
8304 !      include 'COMMON.LOCAL'
8305 !      include 'COMMON.INTERACT'
8306 !      include 'COMMON.CONTACTS'
8307 !      include 'COMMON.CHAIN'
8308 !      include 'COMMON.CONTROL'
8309       real(kind=8),dimension(3) :: gx,gx1
8310       integer,dimension(nres) :: num_cont_hb_old
8311       logical :: lprn,ldone
8312 !EL      double precision eello4,eello5,eelo6,eello_turn6
8313 !EL      external eello4,eello5,eello6,eello_turn6
8314 !el local variables
8315       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8316               j1,jp1,i1,num_conti1
8317       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8318       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8319
8320 ! Set lprn=.true. for debugging
8321       lprn=.false.
8322       eturn6=0.0d0
8323 #ifdef MPI
8324 !      maxconts=nres/4
8325       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8326       do i=1,nres
8327         num_cont_hb_old(i)=num_cont_hb(i)
8328       enddo
8329       n_corr=0
8330       n_corr1=0
8331       if (nfgtasks.le.1) goto 30
8332       if (lprn) then
8333         write (iout,'(a)') 'Contact function values before RECEIVE:'
8334         do i=nnt,nct-2
8335           write (iout,'(2i3,50(1x,i2,f5.2))') &
8336           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8337           j=1,num_cont_hb(i))
8338         enddo
8339       endif
8340       call flush(iout)
8341       do i=1,ntask_cont_from
8342         ncont_recv(i)=0
8343       enddo
8344       do i=1,ntask_cont_to
8345         ncont_sent(i)=0
8346       enddo
8347 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8348 !     & ntask_cont_to
8349 ! Make the list of contacts to send to send to other procesors
8350       do i=iturn3_start,iturn3_end
8351 !        write (iout,*) "make contact list turn3",i," num_cont",
8352 !     &    num_cont_hb(i)
8353         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8354       enddo
8355       do i=iturn4_start,iturn4_end
8356 !        write (iout,*) "make contact list turn4",i," num_cont",
8357 !     &   num_cont_hb(i)
8358         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8359       enddo
8360       do ii=1,nat_sent
8361         i=iat_sent(ii)
8362 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8363 !     &    num_cont_hb(i)
8364         do j=1,num_cont_hb(i)
8365         do k=1,4
8366           jjc=jcont_hb(j,i)
8367           iproc=iint_sent_local(k,jjc,ii)
8368 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8369           if (iproc.ne.0) then
8370             ncont_sent(iproc)=ncont_sent(iproc)+1
8371             nn=ncont_sent(iproc)
8372             zapas(1,nn,iproc)=i
8373             zapas(2,nn,iproc)=jjc
8374             zapas(3,nn,iproc)=d_cont(j,i)
8375             ind=3
8376             do kk=1,3
8377               ind=ind+1
8378               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8379             enddo
8380             do kk=1,2
8381               do ll=1,2
8382                 ind=ind+1
8383                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8384               enddo
8385             enddo
8386             do jj=1,5
8387               do kk=1,3
8388                 do ll=1,2
8389                   do mm=1,2
8390                     ind=ind+1
8391                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8392                   enddo
8393                 enddo
8394               enddo
8395             enddo
8396           endif
8397         enddo
8398         enddo
8399       enddo
8400       if (lprn) then
8401       write (iout,*) &
8402         "Numbers of contacts to be sent to other processors",&
8403         (ncont_sent(i),i=1,ntask_cont_to)
8404       write (iout,*) "Contacts sent"
8405       do ii=1,ntask_cont_to
8406         nn=ncont_sent(ii)
8407         iproc=itask_cont_to(ii)
8408         write (iout,*) nn," contacts to processor",iproc,&
8409          " of CONT_TO_COMM group"
8410         do i=1,nn
8411           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8412         enddo
8413       enddo
8414       call flush(iout)
8415       endif
8416       CorrelType=477
8417       CorrelID=fg_rank+1
8418       CorrelType1=478
8419       CorrelID1=nfgtasks+fg_rank+1
8420       ireq=0
8421 ! Receive the numbers of needed contacts from other processors
8422       do ii=1,ntask_cont_from
8423         iproc=itask_cont_from(ii)
8424         ireq=ireq+1
8425         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8426           FG_COMM,req(ireq),IERR)
8427       enddo
8428 !      write (iout,*) "IRECV ended"
8429 !      call flush(iout)
8430 ! Send the number of contacts needed by other processors
8431       do ii=1,ntask_cont_to
8432         iproc=itask_cont_to(ii)
8433         ireq=ireq+1
8434         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8435           FG_COMM,req(ireq),IERR)
8436       enddo
8437 !      write (iout,*) "ISEND ended"
8438 !      write (iout,*) "number of requests (nn)",ireq
8439       call flush(iout)
8440       if (ireq.gt.0) &
8441         call MPI_Waitall(ireq,req,status_array,ierr)
8442 !      write (iout,*)
8443 !     &  "Numbers of contacts to be received from other processors",
8444 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8445 !      call flush(iout)
8446 ! Receive contacts
8447       ireq=0
8448       do ii=1,ntask_cont_from
8449         iproc=itask_cont_from(ii)
8450         nn=ncont_recv(ii)
8451 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8452 !     &   " of CONT_TO_COMM group"
8453         call flush(iout)
8454         if (nn.gt.0) then
8455           ireq=ireq+1
8456           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8457           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8458 !          write (iout,*) "ireq,req",ireq,req(ireq)
8459         endif
8460       enddo
8461 ! Send the contacts to processors that need them
8462       do ii=1,ntask_cont_to
8463         iproc=itask_cont_to(ii)
8464         nn=ncont_sent(ii)
8465 !        write (iout,*) nn," contacts to processor",iproc,
8466 !     &   " of CONT_TO_COMM group"
8467         if (nn.gt.0) then
8468           ireq=ireq+1
8469           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8470             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8471 !          write (iout,*) "ireq,req",ireq,req(ireq)
8472 !          do i=1,nn
8473 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8474 !          enddo
8475         endif
8476       enddo
8477 !      write (iout,*) "number of requests (contacts)",ireq
8478 !      write (iout,*) "req",(req(i),i=1,4)
8479 !      call flush(iout)
8480       if (ireq.gt.0) &
8481        call MPI_Waitall(ireq,req,status_array,ierr)
8482       do iii=1,ntask_cont_from
8483         iproc=itask_cont_from(iii)
8484         nn=ncont_recv(iii)
8485         if (lprn) then
8486         write (iout,*) "Received",nn," contacts from processor",iproc,&
8487          " of CONT_FROM_COMM group"
8488         call flush(iout)
8489         do i=1,nn
8490           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8491         enddo
8492         call flush(iout)
8493         endif
8494         do i=1,nn
8495           ii=zapas_recv(1,i,iii)
8496 ! Flag the received contacts to prevent double-counting
8497           jj=-zapas_recv(2,i,iii)
8498 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8499 !          call flush(iout)
8500           nnn=num_cont_hb(ii)+1
8501           num_cont_hb(ii)=nnn
8502           jcont_hb(nnn,ii)=jj
8503           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8504           ind=3
8505           do kk=1,3
8506             ind=ind+1
8507             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8508           enddo
8509           do kk=1,2
8510             do ll=1,2
8511               ind=ind+1
8512               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8513             enddo
8514           enddo
8515           do jj=1,5
8516             do kk=1,3
8517               do ll=1,2
8518                 do mm=1,2
8519                   ind=ind+1
8520                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8521                 enddo
8522               enddo
8523             enddo
8524           enddo
8525         enddo
8526       enddo
8527       call flush(iout)
8528       if (lprn) then
8529         write (iout,'(a)') 'Contact function values after receive:'
8530         do i=nnt,nct-2
8531           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8532           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8533           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8534         enddo
8535         call flush(iout)
8536       endif
8537    30 continue
8538 #endif
8539       if (lprn) then
8540         write (iout,'(a)') 'Contact function values:'
8541         do i=nnt,nct-2
8542           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8543           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8544           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8545         enddo
8546       endif
8547       ecorr=0.0D0
8548       ecorr5=0.0d0
8549       ecorr6=0.0d0
8550
8551 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8552 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8553 ! Remove the loop below after debugging !!!
8554       do i=nnt,nct
8555         do j=1,3
8556           gradcorr(j,i)=0.0D0
8557           gradxorr(j,i)=0.0D0
8558         enddo
8559       enddo
8560 ! Calculate the dipole-dipole interaction energies
8561       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8562       do i=iatel_s,iatel_e+1
8563         num_conti=num_cont_hb(i)
8564         do jj=1,num_conti
8565           j=jcont_hb(jj,i)
8566 #ifdef MOMENT
8567           call dipole(i,j,jj)
8568 #endif
8569         enddo
8570       enddo
8571       endif
8572 ! Calculate the local-electrostatic correlation terms
8573 !                write (iout,*) "gradcorr5 in eello5 before loop"
8574 !                do iii=1,nres
8575 !                  write (iout,'(i5,3f10.5)')
8576 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8577 !                enddo
8578       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8579 !        write (iout,*) "corr loop i",i
8580         i1=i+1
8581         num_conti=num_cont_hb(i)
8582         num_conti1=num_cont_hb(i+1)
8583         do jj=1,num_conti
8584           j=jcont_hb(jj,i)
8585           jp=iabs(j)
8586           do kk=1,num_conti1
8587             j1=jcont_hb(kk,i1)
8588             jp1=iabs(j1)
8589 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8590 !     &         ' jj=',jj,' kk=',kk
8591 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8592             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8593                 .or. j.lt.0 .and. j1.gt.0) .and. &
8594                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8595 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8596 ! The system gains extra energy.
8597               n_corr=n_corr+1
8598               sqd1=dsqrt(d_cont(jj,i))
8599               sqd2=dsqrt(d_cont(kk,i1))
8600               sred_geom = sqd1*sqd2
8601               IF (sred_geom.lt.cutoff_corr) THEN
8602                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8603                   ekont,fprimcont)
8604 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8605 !d     &         ' jj=',jj,' kk=',kk
8606                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8607                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8608                 do l=1,3
8609                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8610                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8611                 enddo
8612                 n_corr1=n_corr1+1
8613 !d               write (iout,*) 'sred_geom=',sred_geom,
8614 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8615 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8616 !d               write (iout,*) "g_contij",g_contij
8617 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8618 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8619                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8620                 if (wcorr4.gt.0.0d0) &
8621                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8622                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8623                        write (iout,'(a6,4i5,0pf7.3)') &
8624                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8625 !                write (iout,*) "gradcorr5 before eello5"
8626 !                do iii=1,nres
8627 !                  write (iout,'(i5,3f10.5)')
8628 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8629 !                enddo
8630                 if (wcorr5.gt.0.0d0) &
8631                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8632 !                write (iout,*) "gradcorr5 after eello5"
8633 !                do iii=1,nres
8634 !                  write (iout,'(i5,3f10.5)')
8635 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8636 !                enddo
8637                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8638                        write (iout,'(a6,4i5,0pf7.3)') &
8639                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8640 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8641 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8642                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8643                      .or. wturn6.eq.0.0d0))then
8644 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8645                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8646                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8647                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8648 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8649 !d     &            'ecorr6=',ecorr6
8650 !d                write (iout,'(4e15.5)') sred_geom,
8651 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8652 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8653 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8654                 else if (wturn6.gt.0.0d0 &
8655                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8656 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8657                   eturn6=eturn6+eello_turn6(i,jj,kk)
8658                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8659                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8660 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8661                 endif
8662               ENDIF
8663 1111          continue
8664             endif
8665           enddo ! kk
8666         enddo ! jj
8667       enddo ! i
8668       do i=1,nres
8669         num_cont_hb(i)=num_cont_hb_old(i)
8670       enddo
8671 !                write (iout,*) "gradcorr5 in eello5"
8672 !                do iii=1,nres
8673 !                  write (iout,'(i5,3f10.5)')
8674 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8675 !                enddo
8676       return
8677       end subroutine multibody_eello
8678 !-----------------------------------------------------------------------------
8679       subroutine add_hb_contact_eello(ii,jj,itask)
8680 !      implicit real*8 (a-h,o-z)
8681 !      include "DIMENSIONS"
8682 !      include "COMMON.IOUNITS"
8683 !      include "COMMON.CONTACTS"
8684 !      integer,parameter :: maxconts=nres/4
8685       integer,parameter :: max_dim=70
8686       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8687 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8688 !      common /przechowalnia/ zapas
8689
8690       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8691       integer,dimension(4) ::itask
8692 !      write (iout,*) "itask",itask
8693       do i=1,2
8694         iproc=itask(i)
8695         if (iproc.gt.0) then
8696           do j=1,num_cont_hb(ii)
8697             jjc=jcont_hb(j,ii)
8698 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8699             if (jjc.eq.jj) then
8700               ncont_sent(iproc)=ncont_sent(iproc)+1
8701               nn=ncont_sent(iproc)
8702               zapas(1,nn,iproc)=ii
8703               zapas(2,nn,iproc)=jjc
8704               zapas(3,nn,iproc)=d_cont(j,ii)
8705               ind=3
8706               do kk=1,3
8707                 ind=ind+1
8708                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8709               enddo
8710               do kk=1,2
8711                 do ll=1,2
8712                   ind=ind+1
8713                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8714                 enddo
8715               enddo
8716               do jj=1,5
8717                 do kk=1,3
8718                   do ll=1,2
8719                     do mm=1,2
8720                       ind=ind+1
8721                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8722                     enddo
8723                   enddo
8724                 enddo
8725               enddo
8726               exit
8727             endif
8728           enddo
8729         endif
8730       enddo
8731       return
8732       end subroutine add_hb_contact_eello
8733 !-----------------------------------------------------------------------------
8734       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8735 !      implicit real*8 (a-h,o-z)
8736 !      include 'DIMENSIONS'
8737 !      include 'COMMON.IOUNITS'
8738 !      include 'COMMON.DERIV'
8739 !      include 'COMMON.INTERACT'
8740 !      include 'COMMON.CONTACTS'
8741       real(kind=8),dimension(3) :: gx,gx1
8742       logical :: lprn
8743 !el local variables
8744       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8745       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8746                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8747                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8748                    rlocshield
8749
8750       lprn=.false.
8751       eij=facont_hb(jj,i)
8752       ekl=facont_hb(kk,k)
8753       ees0pij=ees0p(jj,i)
8754       ees0pkl=ees0p(kk,k)
8755       ees0mij=ees0m(jj,i)
8756       ees0mkl=ees0m(kk,k)
8757       ekont=eij*ekl
8758       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8759 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8760 ! Following 4 lines for diagnostics.
8761 !d    ees0pkl=0.0D0
8762 !d    ees0pij=1.0D0
8763 !d    ees0mkl=0.0D0
8764 !d    ees0mij=1.0D0
8765 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8766 !     & 'Contacts ',i,j,
8767 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8768 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8769 !     & 'gradcorr_long'
8770 ! Calculate the multi-body contribution to energy.
8771 !      ecorr=ecorr+ekont*ees
8772 ! Calculate multi-body contributions to the gradient.
8773       coeffpees0pij=coeffp*ees0pij
8774       coeffmees0mij=coeffm*ees0mij
8775       coeffpees0pkl=coeffp*ees0pkl
8776       coeffmees0mkl=coeffm*ees0mkl
8777       do ll=1,3
8778 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8779         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8780         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8781         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8782         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8783         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8784         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8785 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8786         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8787         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8788         coeffmees0mij*gacontm_hb1(ll,kk,k))
8789         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8790         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8791         coeffmees0mij*gacontm_hb2(ll,kk,k))
8792         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8793            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8794            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8795         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8796         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8797         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8798            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8799            coeffmees0mij*gacontm_hb3(ll,kk,k))
8800         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8801         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8802 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8803       enddo
8804 !      write (iout,*)
8805 !grad      do m=i+1,j-1
8806 !grad        do ll=1,3
8807 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8808 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8809 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8810 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8811 !grad        enddo
8812 !grad      enddo
8813 !grad      do m=k+1,l-1
8814 !grad        do ll=1,3
8815 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8816 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8817 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8818 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8819 !grad        enddo
8820 !grad      enddo
8821 !      write (iout,*) "ehbcorr",ekont*ees
8822       ehbcorr=ekont*ees
8823       if (shield_mode.gt.0) then
8824        j=ees0plist(jj,i)
8825        l=ees0plist(kk,k)
8826 !C        print *,i,j,fac_shield(i),fac_shield(j),
8827 !C     &fac_shield(k),fac_shield(l)
8828         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8829            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8830           do ilist=1,ishield_list(i)
8831            iresshield=shield_list(ilist,i)
8832            do m=1,3
8833            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8834            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8835                    rlocshield  &
8836             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8837             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8838             +rlocshield
8839            enddo
8840           enddo
8841           do ilist=1,ishield_list(j)
8842            iresshield=shield_list(ilist,j)
8843            do m=1,3
8844            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8845            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8846                    rlocshield &
8847             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8848            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8849             +rlocshield
8850            enddo
8851           enddo
8852
8853           do ilist=1,ishield_list(k)
8854            iresshield=shield_list(ilist,k)
8855            do m=1,3
8856            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8857            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8858                    rlocshield &
8859             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8860            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8861             +rlocshield
8862            enddo
8863           enddo
8864           do ilist=1,ishield_list(l)
8865            iresshield=shield_list(ilist,l)
8866            do m=1,3
8867            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8868            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8869                    rlocshield &
8870             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8871            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8872             +rlocshield
8873            enddo
8874           enddo
8875           do m=1,3
8876             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8877                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8878             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8879                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8880             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8881                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8882             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8883                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8884
8885             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8886                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8887             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8888                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8889             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8890                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8891             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8892                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8893
8894            enddo
8895       endif
8896       endif
8897       return
8898       end function ehbcorr
8899 #ifdef MOMENT
8900 !-----------------------------------------------------------------------------
8901       subroutine dipole(i,j,jj)
8902 !      implicit real*8 (a-h,o-z)
8903 !      include 'DIMENSIONS'
8904 !      include 'COMMON.IOUNITS'
8905 !      include 'COMMON.CHAIN'
8906 !      include 'COMMON.FFIELD'
8907 !      include 'COMMON.DERIV'
8908 !      include 'COMMON.INTERACT'
8909 !      include 'COMMON.CONTACTS'
8910 !      include 'COMMON.TORSION'
8911 !      include 'COMMON.VAR'
8912 !      include 'COMMON.GEO'
8913       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8914       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8915       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8916
8917       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8918       allocate(dipderx(3,5,4,maxconts,nres))
8919 !
8920
8921       iti1 = itortyp(itype(i+1,1))
8922       if (j.lt.nres-1) then
8923         itj1 = itype2loc(itype(j+1,1))
8924       else
8925         itj1=nloctyp
8926       endif
8927       do iii=1,2
8928         dipi(iii,1)=Ub2(iii,i)
8929         dipderi(iii)=Ub2der(iii,i)
8930         dipi(iii,2)=b1(iii,iti1)
8931         dipj(iii,1)=Ub2(iii,j)
8932         dipderj(iii)=Ub2der(iii,j)
8933         dipj(iii,2)=b1(iii,itj1)
8934       enddo
8935       kkk=0
8936       do iii=1,2
8937         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8938         do jjj=1,2
8939           kkk=kkk+1
8940           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8941         enddo
8942       enddo
8943       do kkk=1,5
8944         do lll=1,3
8945           mmm=0
8946           do iii=1,2
8947             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8948               auxvec(1))
8949             do jjj=1,2
8950               mmm=mmm+1
8951               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8952             enddo
8953           enddo
8954         enddo
8955       enddo
8956       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8957       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8958       do iii=1,2
8959         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8960       enddo
8961       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8962       do iii=1,2
8963         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8964       enddo
8965       return
8966       end subroutine dipole
8967 #endif
8968 !-----------------------------------------------------------------------------
8969       subroutine calc_eello(i,j,k,l,jj,kk)
8970 !
8971 ! This subroutine computes matrices and vectors needed to calculate
8972 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8973 !
8974       use comm_kut
8975 !      implicit real*8 (a-h,o-z)
8976 !      include 'DIMENSIONS'
8977 !      include 'COMMON.IOUNITS'
8978 !      include 'COMMON.CHAIN'
8979 !      include 'COMMON.DERIV'
8980 !      include 'COMMON.INTERACT'
8981 !      include 'COMMON.CONTACTS'
8982 !      include 'COMMON.TORSION'
8983 !      include 'COMMON.VAR'
8984 !      include 'COMMON.GEO'
8985 !      include 'COMMON.FFIELD'
8986       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8987       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8988       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8989               itj1
8990 !el      logical :: lprn
8991 !el      common /kutas/ lprn
8992 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8993 !d     & ' jj=',jj,' kk=',kk
8994 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8995 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8996 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8997       do iii=1,2
8998         do jjj=1,2
8999           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9000           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9001         enddo
9002       enddo
9003       call transpose2(aa1(1,1),aa1t(1,1))
9004       call transpose2(aa2(1,1),aa2t(1,1))
9005       do kkk=1,5
9006         do lll=1,3
9007           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9008             aa1tder(1,1,lll,kkk))
9009           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9010             aa2tder(1,1,lll,kkk))
9011         enddo
9012       enddo
9013       if (l.eq.j+1) then
9014 ! parallel orientation of the two CA-CA-CA frames.
9015         if (i.gt.1) then
9016           iti=itortyp(itype(i,1))
9017         else
9018           iti=ntortyp+1
9019         endif
9020         itk1=itortyp(itype(k+1,1))
9021         itj=itortyp(itype(j,1))
9022         if (l.lt.nres-1) then
9023           itl1=itortyp(itype(l+1,1))
9024         else
9025           itl1=ntortyp+1
9026         endif
9027 ! A1 kernel(j+1) A2T
9028 !d        do iii=1,2
9029 !d          write (iout,'(3f10.5,5x,3f10.5)')
9030 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9031 !d        enddo
9032         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9033          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9034          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9035 ! Following matrices are needed only for 6-th order cumulants
9036         IF (wcorr6.gt.0.0d0) THEN
9037         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9038          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9039          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9040         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9041          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9042          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9043          ADtEAderx(1,1,1,1,1,1))
9044         lprn=.false.
9045         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9046          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9047          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9048          ADtEA1derx(1,1,1,1,1,1))
9049         ENDIF
9050 ! End 6-th order cumulants
9051 !d        lprn=.false.
9052 !d        if (lprn) then
9053 !d        write (2,*) 'In calc_eello6'
9054 !d        do iii=1,2
9055 !d          write (2,*) 'iii=',iii
9056 !d          do kkk=1,5
9057 !d            write (2,*) 'kkk=',kkk
9058 !d            do jjj=1,2
9059 !d              write (2,'(3(2f10.5),5x)')
9060 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9061 !d            enddo
9062 !d          enddo
9063 !d        enddo
9064 !d        endif
9065         call transpose2(EUgder(1,1,k),auxmat(1,1))
9066         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9067         call transpose2(EUg(1,1,k),auxmat(1,1))
9068         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9069         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9070         do iii=1,2
9071           do kkk=1,5
9072             do lll=1,3
9073               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9074                 EAEAderx(1,1,lll,kkk,iii,1))
9075             enddo
9076           enddo
9077         enddo
9078 ! A1T kernel(i+1) A2
9079         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9080          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9081          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9082 ! Following matrices are needed only for 6-th order cumulants
9083         IF (wcorr6.gt.0.0d0) THEN
9084         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9085          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9086          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9087         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9088          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9089          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9090          ADtEAderx(1,1,1,1,1,2))
9091         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9092          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9093          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9094          ADtEA1derx(1,1,1,1,1,2))
9095         ENDIF
9096 ! End 6-th order cumulants
9097         call transpose2(EUgder(1,1,l),auxmat(1,1))
9098         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9099         call transpose2(EUg(1,1,l),auxmat(1,1))
9100         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9101         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9102         do iii=1,2
9103           do kkk=1,5
9104             do lll=1,3
9105               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9106                 EAEAderx(1,1,lll,kkk,iii,2))
9107             enddo
9108           enddo
9109         enddo
9110 ! AEAb1 and AEAb2
9111 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9112 ! They are needed only when the fifth- or the sixth-order cumulants are
9113 ! indluded.
9114         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9115         call transpose2(AEA(1,1,1),auxmat(1,1))
9116         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9117         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9118         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9119         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9120         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9121         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9122         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9123         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9124         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9125         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9126         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9127         call transpose2(AEA(1,1,2),auxmat(1,1))
9128         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9129         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9130         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9131         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9132         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9133         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9134         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9135         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9136         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9137         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9138         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9139 ! Calculate the Cartesian derivatives of the vectors.
9140         do iii=1,2
9141           do kkk=1,5
9142             do lll=1,3
9143               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9144               call matvec2(auxmat(1,1),b1(1,iti),&
9145                 AEAb1derx(1,lll,kkk,iii,1,1))
9146               call matvec2(auxmat(1,1),Ub2(1,i),&
9147                 AEAb2derx(1,lll,kkk,iii,1,1))
9148               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9149                 AEAb1derx(1,lll,kkk,iii,2,1))
9150               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9151                 AEAb2derx(1,lll,kkk,iii,2,1))
9152               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9153               call matvec2(auxmat(1,1),b1(1,itj),&
9154                 AEAb1derx(1,lll,kkk,iii,1,2))
9155               call matvec2(auxmat(1,1),Ub2(1,j),&
9156                 AEAb2derx(1,lll,kkk,iii,1,2))
9157               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9158                 AEAb1derx(1,lll,kkk,iii,2,2))
9159               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9160                 AEAb2derx(1,lll,kkk,iii,2,2))
9161             enddo
9162           enddo
9163         enddo
9164         ENDIF
9165 ! End vectors
9166       else
9167 ! Antiparallel orientation of the two CA-CA-CA frames.
9168         if (i.gt.1) then
9169           iti=itortyp(itype(i,1))
9170         else
9171           iti=ntortyp+1
9172         endif
9173         itk1=itortyp(itype(k+1,1))
9174         itl=itortyp(itype(l,1))
9175         itj=itortyp(itype(j,1))
9176         if (j.lt.nres-1) then
9177           itj1=itortyp(itype(j+1,1))
9178         else
9179           itj1=ntortyp+1
9180         endif
9181 ! A2 kernel(j-1)T A1T
9182         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9183          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9184          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9185 ! Following matrices are needed only for 6-th order cumulants
9186         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9187            j.eq.i+4 .and. l.eq.i+3)) THEN
9188         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9189          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9190          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9191         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9192          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9193          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9194          ADtEAderx(1,1,1,1,1,1))
9195         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9196          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9197          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9198          ADtEA1derx(1,1,1,1,1,1))
9199         ENDIF
9200 ! End 6-th order cumulants
9201         call transpose2(EUgder(1,1,k),auxmat(1,1))
9202         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9203         call transpose2(EUg(1,1,k),auxmat(1,1))
9204         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9205         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9206         do iii=1,2
9207           do kkk=1,5
9208             do lll=1,3
9209               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9210                 EAEAderx(1,1,lll,kkk,iii,1))
9211             enddo
9212           enddo
9213         enddo
9214 ! A2T kernel(i+1)T A1
9215         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9216          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9217          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9218 ! Following matrices are needed only for 6-th order cumulants
9219         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9220            j.eq.i+4 .and. l.eq.i+3)) THEN
9221         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9222          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9223          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9224         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9225          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9226          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9227          ADtEAderx(1,1,1,1,1,2))
9228         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9229          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9230          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9231          ADtEA1derx(1,1,1,1,1,2))
9232         ENDIF
9233 ! End 6-th order cumulants
9234         call transpose2(EUgder(1,1,j),auxmat(1,1))
9235         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9236         call transpose2(EUg(1,1,j),auxmat(1,1))
9237         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9238         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9239         do iii=1,2
9240           do kkk=1,5
9241             do lll=1,3
9242               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9243                 EAEAderx(1,1,lll,kkk,iii,2))
9244             enddo
9245           enddo
9246         enddo
9247 ! AEAb1 and AEAb2
9248 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9249 ! They are needed only when the fifth- or the sixth-order cumulants are
9250 ! indluded.
9251         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9252           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9253         call transpose2(AEA(1,1,1),auxmat(1,1))
9254         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9255         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9256         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9257         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9258         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9259         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9260         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9261         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9262         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9263         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9264         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9265         call transpose2(AEA(1,1,2),auxmat(1,1))
9266         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9267         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9268         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9269         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9270         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9271         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9272         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9273         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9274         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9275         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9276         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9277 ! Calculate the Cartesian derivatives of the vectors.
9278         do iii=1,2
9279           do kkk=1,5
9280             do lll=1,3
9281               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9282               call matvec2(auxmat(1,1),b1(1,iti),&
9283                 AEAb1derx(1,lll,kkk,iii,1,1))
9284               call matvec2(auxmat(1,1),Ub2(1,i),&
9285                 AEAb2derx(1,lll,kkk,iii,1,1))
9286               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9287                 AEAb1derx(1,lll,kkk,iii,2,1))
9288               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9289                 AEAb2derx(1,lll,kkk,iii,2,1))
9290               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9291               call matvec2(auxmat(1,1),b1(1,itl),&
9292                 AEAb1derx(1,lll,kkk,iii,1,2))
9293               call matvec2(auxmat(1,1),Ub2(1,l),&
9294                 AEAb2derx(1,lll,kkk,iii,1,2))
9295               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9296                 AEAb1derx(1,lll,kkk,iii,2,2))
9297               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9298                 AEAb2derx(1,lll,kkk,iii,2,2))
9299             enddo
9300           enddo
9301         enddo
9302         ENDIF
9303 ! End vectors
9304       endif
9305       return
9306       end subroutine calc_eello
9307 !-----------------------------------------------------------------------------
9308       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9309       use comm_kut
9310       implicit none
9311       integer :: nderg
9312       logical :: transp
9313       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9314       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9315       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9316       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9317       integer :: iii,kkk,lll
9318       integer :: jjj,mmm
9319 !el      logical :: lprn
9320 !el      common /kutas/ lprn
9321       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9322       do iii=1,nderg
9323         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9324           AKAderg(1,1,iii))
9325       enddo
9326 !d      if (lprn) write (2,*) 'In kernel'
9327       do kkk=1,5
9328 !d        if (lprn) write (2,*) 'kkk=',kkk
9329         do lll=1,3
9330           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9331             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9332 !d          if (lprn) then
9333 !d            write (2,*) 'lll=',lll
9334 !d            write (2,*) 'iii=1'
9335 !d            do jjj=1,2
9336 !d              write (2,'(3(2f10.5),5x)')
9337 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9338 !d            enddo
9339 !d          endif
9340           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9341             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9342 !d          if (lprn) then
9343 !d            write (2,*) 'lll=',lll
9344 !d            write (2,*) 'iii=2'
9345 !d            do jjj=1,2
9346 !d              write (2,'(3(2f10.5),5x)')
9347 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9348 !d            enddo
9349 !d          endif
9350         enddo
9351       enddo
9352       return
9353       end subroutine kernel
9354 !-----------------------------------------------------------------------------
9355       real(kind=8) function eello4(i,j,k,l,jj,kk)
9356 !      implicit real*8 (a-h,o-z)
9357 !      include 'DIMENSIONS'
9358 !      include 'COMMON.IOUNITS'
9359 !      include 'COMMON.CHAIN'
9360 !      include 'COMMON.DERIV'
9361 !      include 'COMMON.INTERACT'
9362 !      include 'COMMON.CONTACTS'
9363 !      include 'COMMON.TORSION'
9364 !      include 'COMMON.VAR'
9365 !      include 'COMMON.GEO'
9366       real(kind=8),dimension(2,2) :: pizda
9367       real(kind=8),dimension(3) :: ggg1,ggg2
9368       real(kind=8) ::  eel4,glongij,glongkl
9369       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9370 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9371 !d        eello4=0.0d0
9372 !d        return
9373 !d      endif
9374 !d      print *,'eello4:',i,j,k,l,jj,kk
9375 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9376 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9377 !old      eij=facont_hb(jj,i)
9378 !old      ekl=facont_hb(kk,k)
9379 !old      ekont=eij*ekl
9380       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9381 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9382       gcorr_loc(k-1)=gcorr_loc(k-1) &
9383          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9384       if (l.eq.j+1) then
9385         gcorr_loc(l-1)=gcorr_loc(l-1) &
9386            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9387       else
9388         gcorr_loc(j-1)=gcorr_loc(j-1) &
9389            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9390       endif
9391       do iii=1,2
9392         do kkk=1,5
9393           do lll=1,3
9394             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9395                               -EAEAderx(2,2,lll,kkk,iii,1)
9396 !d            derx(lll,kkk,iii)=0.0d0
9397           enddo
9398         enddo
9399       enddo
9400 !d      gcorr_loc(l-1)=0.0d0
9401 !d      gcorr_loc(j-1)=0.0d0
9402 !d      gcorr_loc(k-1)=0.0d0
9403 !d      eel4=1.0d0
9404 !d      write (iout,*)'Contacts have occurred for peptide groups',
9405 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9406 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9407       if (j.lt.nres-1) then
9408         j1=j+1
9409         j2=j-1
9410       else
9411         j1=j-1
9412         j2=j-2
9413       endif
9414       if (l.lt.nres-1) then
9415         l1=l+1
9416         l2=l-1
9417       else
9418         l1=l-1
9419         l2=l-2
9420       endif
9421       do ll=1,3
9422 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9423 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9424         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9425         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9426 !grad        ghalf=0.5d0*ggg1(ll)
9427         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9428         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9429         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9430         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9431         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9432         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9433 !grad        ghalf=0.5d0*ggg2(ll)
9434         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9435         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9436         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9437         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9438         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9439         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9440       enddo
9441 !grad      do m=i+1,j-1
9442 !grad        do ll=1,3
9443 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9444 !grad        enddo
9445 !grad      enddo
9446 !grad      do m=k+1,l-1
9447 !grad        do ll=1,3
9448 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9449 !grad        enddo
9450 !grad      enddo
9451 !grad      do m=i+2,j2
9452 !grad        do ll=1,3
9453 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9454 !grad        enddo
9455 !grad      enddo
9456 !grad      do m=k+2,l2
9457 !grad        do ll=1,3
9458 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9459 !grad        enddo
9460 !grad      enddo
9461 !d      do iii=1,nres-3
9462 !d        write (2,*) iii,gcorr_loc(iii)
9463 !d      enddo
9464       eello4=ekont*eel4
9465 !d      write (2,*) 'ekont',ekont
9466 !d      write (iout,*) 'eello4',ekont*eel4
9467       return
9468       end function eello4
9469 !-----------------------------------------------------------------------------
9470       real(kind=8) function eello5(i,j,k,l,jj,kk)
9471 !      implicit real*8 (a-h,o-z)
9472 !      include 'DIMENSIONS'
9473 !      include 'COMMON.IOUNITS'
9474 !      include 'COMMON.CHAIN'
9475 !      include 'COMMON.DERIV'
9476 !      include 'COMMON.INTERACT'
9477 !      include 'COMMON.CONTACTS'
9478 !      include 'COMMON.TORSION'
9479 !      include 'COMMON.VAR'
9480 !      include 'COMMON.GEO'
9481       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9482       real(kind=8),dimension(2) :: vv
9483       real(kind=8),dimension(3) :: ggg1,ggg2
9484       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9485       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9486       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9487 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9488 !                                                                              C
9489 !                            Parallel chains                                   C
9490 !                                                                              C
9491 !          o             o                   o             o                   C
9492 !         /l\           / \             \   / \           / \   /              C
9493 !        /   \         /   \             \ /   \         /   \ /               C
9494 !       j| o |l1       | o |                o| o |         | o |o                C
9495 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9496 !      \i/   \         /   \ /             /   \         /   \                 C
9497 !       o    k1             o                                                  C
9498 !         (I)          (II)                (III)          (IV)                 C
9499 !                                                                              C
9500 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9501 !                                                                              C
9502 !                            Antiparallel chains                               C
9503 !                                                                              C
9504 !          o             o                   o             o                   C
9505 !         /j\           / \             \   / \           / \   /              C
9506 !        /   \         /   \             \ /   \         /   \ /               C
9507 !      j1| o |l        | o |                o| o |         | o |o                C
9508 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9509 !      \i/   \         /   \ /             /   \         /   \                 C
9510 !       o     k1            o                                                  C
9511 !         (I)          (II)                (III)          (IV)                 C
9512 !                                                                              C
9513 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9514 !                                                                              C
9515 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9516 !                                                                              C
9517 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9518 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9519 !d        eello5=0.0d0
9520 !d        return
9521 !d      endif
9522 !d      write (iout,*)
9523 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9524 !d     &   ' and',k,l
9525       itk=itortyp(itype(k,1))
9526       itl=itortyp(itype(l,1))
9527       itj=itortyp(itype(j,1))
9528       eello5_1=0.0d0
9529       eello5_2=0.0d0
9530       eello5_3=0.0d0
9531       eello5_4=0.0d0
9532 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9533 !d     &   eel5_3_num,eel5_4_num)
9534       do iii=1,2
9535         do kkk=1,5
9536           do lll=1,3
9537             derx(lll,kkk,iii)=0.0d0
9538           enddo
9539         enddo
9540       enddo
9541 !d      eij=facont_hb(jj,i)
9542 !d      ekl=facont_hb(kk,k)
9543 !d      ekont=eij*ekl
9544 !d      write (iout,*)'Contacts have occurred for peptide groups',
9545 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9546 !d      goto 1111
9547 ! Contribution from the graph I.
9548 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9549 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9550       call transpose2(EUg(1,1,k),auxmat(1,1))
9551       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9552       vv(1)=pizda(1,1)-pizda(2,2)
9553       vv(2)=pizda(1,2)+pizda(2,1)
9554       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9555        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9556 ! Explicit gradient in virtual-dihedral angles.
9557       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9558        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9559        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9560       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9561       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9562       vv(1)=pizda(1,1)-pizda(2,2)
9563       vv(2)=pizda(1,2)+pizda(2,1)
9564       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9565        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9566        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9567       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9568       vv(1)=pizda(1,1)-pizda(2,2)
9569       vv(2)=pizda(1,2)+pizda(2,1)
9570       if (l.eq.j+1) then
9571         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9572          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9573          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9574       else
9575         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9576          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9577          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9578       endif
9579 ! Cartesian gradient
9580       do iii=1,2
9581         do kkk=1,5
9582           do lll=1,3
9583             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9584               pizda(1,1))
9585             vv(1)=pizda(1,1)-pizda(2,2)
9586             vv(2)=pizda(1,2)+pizda(2,1)
9587             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9588              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9589              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9590           enddo
9591         enddo
9592       enddo
9593 !      goto 1112
9594 !1111  continue
9595 ! Contribution from graph II
9596       call transpose2(EE(1,1,itk),auxmat(1,1))
9597       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9598       vv(1)=pizda(1,1)+pizda(2,2)
9599       vv(2)=pizda(2,1)-pizda(1,2)
9600       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9601        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9602 ! Explicit gradient in virtual-dihedral angles.
9603       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9604        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9605       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9606       vv(1)=pizda(1,1)+pizda(2,2)
9607       vv(2)=pizda(2,1)-pizda(1,2)
9608       if (l.eq.j+1) then
9609         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9610          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9611          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9612       else
9613         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9614          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9615          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9616       endif
9617 ! Cartesian gradient
9618       do iii=1,2
9619         do kkk=1,5
9620           do lll=1,3
9621             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9622               pizda(1,1))
9623             vv(1)=pizda(1,1)+pizda(2,2)
9624             vv(2)=pizda(2,1)-pizda(1,2)
9625             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9626              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9627              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9628           enddo
9629         enddo
9630       enddo
9631 !d      goto 1112
9632 !d1111  continue
9633       if (l.eq.j+1) then
9634 !d        goto 1110
9635 ! Parallel orientation
9636 ! Contribution from graph III
9637         call transpose2(EUg(1,1,l),auxmat(1,1))
9638         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9639         vv(1)=pizda(1,1)-pizda(2,2)
9640         vv(2)=pizda(1,2)+pizda(2,1)
9641         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9642          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9643 ! Explicit gradient in virtual-dihedral angles.
9644         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9645          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9646          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9647         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9648         vv(1)=pizda(1,1)-pizda(2,2)
9649         vv(2)=pizda(1,2)+pizda(2,1)
9650         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9651          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9652          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9653         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9654         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9655         vv(1)=pizda(1,1)-pizda(2,2)
9656         vv(2)=pizda(1,2)+pizda(2,1)
9657         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9658          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9659          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9660 ! Cartesian gradient
9661         do iii=1,2
9662           do kkk=1,5
9663             do lll=1,3
9664               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9665                 pizda(1,1))
9666               vv(1)=pizda(1,1)-pizda(2,2)
9667               vv(2)=pizda(1,2)+pizda(2,1)
9668               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9669                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9670                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9671             enddo
9672           enddo
9673         enddo
9674 !d        goto 1112
9675 ! Contribution from graph IV
9676 !d1110    continue
9677         call transpose2(EE(1,1,itl),auxmat(1,1))
9678         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9679         vv(1)=pizda(1,1)+pizda(2,2)
9680         vv(2)=pizda(2,1)-pizda(1,2)
9681         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9682          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9683 ! Explicit gradient in virtual-dihedral angles.
9684         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9685          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9686         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9687         vv(1)=pizda(1,1)+pizda(2,2)
9688         vv(2)=pizda(2,1)-pizda(1,2)
9689         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9690          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9691          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9692 ! Cartesian gradient
9693         do iii=1,2
9694           do kkk=1,5
9695             do lll=1,3
9696               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9697                 pizda(1,1))
9698               vv(1)=pizda(1,1)+pizda(2,2)
9699               vv(2)=pizda(2,1)-pizda(1,2)
9700               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9701                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9702                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9703             enddo
9704           enddo
9705         enddo
9706       else
9707 ! Antiparallel orientation
9708 ! Contribution from graph III
9709 !        goto 1110
9710         call transpose2(EUg(1,1,j),auxmat(1,1))
9711         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9712         vv(1)=pizda(1,1)-pizda(2,2)
9713         vv(2)=pizda(1,2)+pizda(2,1)
9714         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9715          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9716 ! Explicit gradient in virtual-dihedral angles.
9717         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9718          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9719          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9720         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9721         vv(1)=pizda(1,1)-pizda(2,2)
9722         vv(2)=pizda(1,2)+pizda(2,1)
9723         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9724          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9725          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9726         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9727         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9728         vv(1)=pizda(1,1)-pizda(2,2)
9729         vv(2)=pizda(1,2)+pizda(2,1)
9730         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9731          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9732          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9733 ! Cartesian gradient
9734         do iii=1,2
9735           do kkk=1,5
9736             do lll=1,3
9737               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9738                 pizda(1,1))
9739               vv(1)=pizda(1,1)-pizda(2,2)
9740               vv(2)=pizda(1,2)+pizda(2,1)
9741               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9742                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9743                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9744             enddo
9745           enddo
9746         enddo
9747 !d        goto 1112
9748 ! Contribution from graph IV
9749 1110    continue
9750         call transpose2(EE(1,1,itj),auxmat(1,1))
9751         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9752         vv(1)=pizda(1,1)+pizda(2,2)
9753         vv(2)=pizda(2,1)-pizda(1,2)
9754         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9755          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9756 ! Explicit gradient in virtual-dihedral angles.
9757         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9758          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9759         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9760         vv(1)=pizda(1,1)+pizda(2,2)
9761         vv(2)=pizda(2,1)-pizda(1,2)
9762         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9763          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9764          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9765 ! Cartesian gradient
9766         do iii=1,2
9767           do kkk=1,5
9768             do lll=1,3
9769               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9770                 pizda(1,1))
9771               vv(1)=pizda(1,1)+pizda(2,2)
9772               vv(2)=pizda(2,1)-pizda(1,2)
9773               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9774                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9775                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9776             enddo
9777           enddo
9778         enddo
9779       endif
9780 1112  continue
9781       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9782 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9783 !d        write (2,*) 'ijkl',i,j,k,l
9784 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9785 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9786 !d      endif
9787 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9788 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9789 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9790 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9791       if (j.lt.nres-1) then
9792         j1=j+1
9793         j2=j-1
9794       else
9795         j1=j-1
9796         j2=j-2
9797       endif
9798       if (l.lt.nres-1) then
9799         l1=l+1
9800         l2=l-1
9801       else
9802         l1=l-1
9803         l2=l-2
9804       endif
9805 !d      eij=1.0d0
9806 !d      ekl=1.0d0
9807 !d      ekont=1.0d0
9808 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9809 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9810 !        summed up outside the subrouine as for the other subroutines
9811 !        handling long-range interactions. The old code is commented out
9812 !        with "cgrad" to keep track of changes.
9813       do ll=1,3
9814 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9815 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9816         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9817         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9818 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9819 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9820 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9821 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9822 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9823 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9824 !     &   gradcorr5ij,
9825 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9826 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9827 !grad        ghalf=0.5d0*ggg1(ll)
9828 !d        ghalf=0.0d0
9829         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9830         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9831         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9832         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9833         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9834         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9835 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9836 !grad        ghalf=0.5d0*ggg2(ll)
9837         ghalf=0.0d0
9838         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9839         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9840         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9841         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9842         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9843         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9844       enddo
9845 !d      goto 1112
9846 !grad      do m=i+1,j-1
9847 !grad        do ll=1,3
9848 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9849 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9850 !grad        enddo
9851 !grad      enddo
9852 !grad      do m=k+1,l-1
9853 !grad        do ll=1,3
9854 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9855 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9856 !grad        enddo
9857 !grad      enddo
9858 !1112  continue
9859 !grad      do m=i+2,j2
9860 !grad        do ll=1,3
9861 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9862 !grad        enddo
9863 !grad      enddo
9864 !grad      do m=k+2,l2
9865 !grad        do ll=1,3
9866 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9867 !grad        enddo
9868 !grad      enddo
9869 !d      do iii=1,nres-3
9870 !d        write (2,*) iii,g_corr5_loc(iii)
9871 !d      enddo
9872       eello5=ekont*eel5
9873 !d      write (2,*) 'ekont',ekont
9874 !d      write (iout,*) 'eello5',ekont*eel5
9875       return
9876       end function eello5
9877 !-----------------------------------------------------------------------------
9878       real(kind=8) function eello6(i,j,k,l,jj,kk)
9879 !      implicit real*8 (a-h,o-z)
9880 !      include 'DIMENSIONS'
9881 !      include 'COMMON.IOUNITS'
9882 !      include 'COMMON.CHAIN'
9883 !      include 'COMMON.DERIV'
9884 !      include 'COMMON.INTERACT'
9885 !      include 'COMMON.CONTACTS'
9886 !      include 'COMMON.TORSION'
9887 !      include 'COMMON.VAR'
9888 !      include 'COMMON.GEO'
9889 !      include 'COMMON.FFIELD'
9890       real(kind=8),dimension(3) :: ggg1,ggg2
9891       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9892                    eello6_6,eel6
9893       real(kind=8) :: gradcorr6ij,gradcorr6kl
9894       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9895 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9896 !d        eello6=0.0d0
9897 !d        return
9898 !d      endif
9899 !d      write (iout,*)
9900 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9901 !d     &   ' and',k,l
9902       eello6_1=0.0d0
9903       eello6_2=0.0d0
9904       eello6_3=0.0d0
9905       eello6_4=0.0d0
9906       eello6_5=0.0d0
9907       eello6_6=0.0d0
9908 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9909 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9910       do iii=1,2
9911         do kkk=1,5
9912           do lll=1,3
9913             derx(lll,kkk,iii)=0.0d0
9914           enddo
9915         enddo
9916       enddo
9917 !d      eij=facont_hb(jj,i)
9918 !d      ekl=facont_hb(kk,k)
9919 !d      ekont=eij*ekl
9920 !d      eij=1.0d0
9921 !d      ekl=1.0d0
9922 !d      ekont=1.0d0
9923       if (l.eq.j+1) then
9924         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9925         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9926         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9927         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9928         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9929         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9930       else
9931         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9932         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9933         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9934         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9935         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9936           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9937         else
9938           eello6_5=0.0d0
9939         endif
9940         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9941       endif
9942 ! If turn contributions are considered, they will be handled separately.
9943       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9944 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9945 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9946 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9947 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9948 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9949 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9950 !d      goto 1112
9951       if (j.lt.nres-1) then
9952         j1=j+1
9953         j2=j-1
9954       else
9955         j1=j-1
9956         j2=j-2
9957       endif
9958       if (l.lt.nres-1) then
9959         l1=l+1
9960         l2=l-1
9961       else
9962         l1=l-1
9963         l2=l-2
9964       endif
9965       do ll=1,3
9966 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9967 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9968 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9969 !grad        ghalf=0.5d0*ggg1(ll)
9970 !d        ghalf=0.0d0
9971         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9972         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9973         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9974         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9975         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9976         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9977         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9978         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9979 !grad        ghalf=0.5d0*ggg2(ll)
9980 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9981 !d        ghalf=0.0d0
9982         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9983         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9984         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9985         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9986         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9987         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9988       enddo
9989 !d      goto 1112
9990 !grad      do m=i+1,j-1
9991 !grad        do ll=1,3
9992 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9993 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9994 !grad        enddo
9995 !grad      enddo
9996 !grad      do m=k+1,l-1
9997 !grad        do ll=1,3
9998 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9999 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10000 !grad        enddo
10001 !grad      enddo
10002 !grad1112  continue
10003 !grad      do m=i+2,j2
10004 !grad        do ll=1,3
10005 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10006 !grad        enddo
10007 !grad      enddo
10008 !grad      do m=k+2,l2
10009 !grad        do ll=1,3
10010 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10011 !grad        enddo
10012 !grad      enddo
10013 !d      do iii=1,nres-3
10014 !d        write (2,*) iii,g_corr6_loc(iii)
10015 !d      enddo
10016       eello6=ekont*eel6
10017 !d      write (2,*) 'ekont',ekont
10018 !d      write (iout,*) 'eello6',ekont*eel6
10019       return
10020       end function eello6
10021 !-----------------------------------------------------------------------------
10022       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10023       use comm_kut
10024 !      implicit real*8 (a-h,o-z)
10025 !      include 'DIMENSIONS'
10026 !      include 'COMMON.IOUNITS'
10027 !      include 'COMMON.CHAIN'
10028 !      include 'COMMON.DERIV'
10029 !      include 'COMMON.INTERACT'
10030 !      include 'COMMON.CONTACTS'
10031 !      include 'COMMON.TORSION'
10032 !      include 'COMMON.VAR'
10033 !      include 'COMMON.GEO'
10034       real(kind=8),dimension(2) :: vv,vv1
10035       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10036       logical :: swap
10037 !el      logical :: lprn
10038 !el      common /kutas/ lprn
10039       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10040       real(kind=8) :: s1,s2,s3,s4,s5
10041 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10042 !                                                                              C
10043 !      Parallel       Antiparallel                                             C
10044 !                                                                              C
10045 !          o             o                                                     C
10046 !         /l\           /j\                                                    C
10047 !        /   \         /   \                                                   C
10048 !       /| o |         | o |\                                                  C
10049 !     \ j|/k\|  /   \  |/k\|l /                                                C
10050 !      \ /   \ /     \ /   \ /                                                 C
10051 !       o     o       o     o                                                  C
10052 !       i             i                                                        C
10053 !                                                                              C
10054 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10055       itk=itortyp(itype(k,1))
10056       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10057       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10058       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10059       call transpose2(EUgC(1,1,k),auxmat(1,1))
10060       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10061       vv1(1)=pizda1(1,1)-pizda1(2,2)
10062       vv1(2)=pizda1(1,2)+pizda1(2,1)
10063       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10064       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10065       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10066       s5=scalar2(vv(1),Dtobr2(1,i))
10067 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10068       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10069       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10070        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10071        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10072        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10073        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10074        +scalar2(vv(1),Dtobr2der(1,i)))
10075       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10076       vv1(1)=pizda1(1,1)-pizda1(2,2)
10077       vv1(2)=pizda1(1,2)+pizda1(2,1)
10078       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10079       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10080       if (l.eq.j+1) then
10081         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10082        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10083        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10084        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10085        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10086       else
10087         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10088        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10089        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10090        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10091        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10092       endif
10093       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10094       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10095       vv1(1)=pizda1(1,1)-pizda1(2,2)
10096       vv1(2)=pizda1(1,2)+pizda1(2,1)
10097       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10098        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10099        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10100        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10101       do iii=1,2
10102         if (swap) then
10103           ind=3-iii
10104         else
10105           ind=iii
10106         endif
10107         do kkk=1,5
10108           do lll=1,3
10109             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10110             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10111             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10112             call transpose2(EUgC(1,1,k),auxmat(1,1))
10113             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10114               pizda1(1,1))
10115             vv1(1)=pizda1(1,1)-pizda1(2,2)
10116             vv1(2)=pizda1(1,2)+pizda1(2,1)
10117             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10118             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10119              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10120             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10121              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10122             s5=scalar2(vv(1),Dtobr2(1,i))
10123             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10124           enddo
10125         enddo
10126       enddo
10127       return
10128       end function eello6_graph1
10129 !-----------------------------------------------------------------------------
10130       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10131       use comm_kut
10132 !      implicit real*8 (a-h,o-z)
10133 !      include 'DIMENSIONS'
10134 !      include 'COMMON.IOUNITS'
10135 !      include 'COMMON.CHAIN'
10136 !      include 'COMMON.DERIV'
10137 !      include 'COMMON.INTERACT'
10138 !      include 'COMMON.CONTACTS'
10139 !      include 'COMMON.TORSION'
10140 !      include 'COMMON.VAR'
10141 !      include 'COMMON.GEO'
10142       logical :: swap
10143       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10144       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10145 !el      logical :: lprn
10146 !el      common /kutas/ lprn
10147       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10148       real(kind=8) :: s2,s3,s4
10149 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10150 !                                                                              C
10151 !      Parallel       Antiparallel                                             C
10152 !                                                                              C
10153 !          o             o                                                     C
10154 !     \   /l\           /j\   /                                                C
10155 !      \ /   \         /   \ /                                                 C
10156 !       o| o |         | o |o                                                  C
10157 !     \ j|/k\|      \  |/k\|l                                                  C
10158 !      \ /   \       \ /   \                                                   C
10159 !       o             o                                                        C
10160 !       i             i                                                        C
10161 !                                                                              C
10162 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10163 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10164 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10165 !           but not in a cluster cumulant
10166 #ifdef MOMENT
10167       s1=dip(1,jj,i)*dip(1,kk,k)
10168 #endif
10169       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10170       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10171       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10172       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10173       call transpose2(EUg(1,1,k),auxmat(1,1))
10174       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10175       vv(1)=pizda(1,1)-pizda(2,2)
10176       vv(2)=pizda(1,2)+pizda(2,1)
10177       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10178 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10179 #ifdef MOMENT
10180       eello6_graph2=-(s1+s2+s3+s4)
10181 #else
10182       eello6_graph2=-(s2+s3+s4)
10183 #endif
10184 !      eello6_graph2=-s3
10185 ! Derivatives in gamma(i-1)
10186       if (i.gt.1) then
10187 #ifdef MOMENT
10188         s1=dipderg(1,jj,i)*dip(1,kk,k)
10189 #endif
10190         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10191         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10192         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10193         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10194 #ifdef MOMENT
10195         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10196 #else
10197         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10198 #endif
10199 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10200       endif
10201 ! Derivatives in gamma(k-1)
10202 #ifdef MOMENT
10203       s1=dip(1,jj,i)*dipderg(1,kk,k)
10204 #endif
10205       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10206       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10207       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10208       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10209       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10210       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10211       vv(1)=pizda(1,1)-pizda(2,2)
10212       vv(2)=pizda(1,2)+pizda(2,1)
10213       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10214 #ifdef MOMENT
10215       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10216 #else
10217       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10218 #endif
10219 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10220 ! Derivatives in gamma(j-1) or gamma(l-1)
10221       if (j.gt.1) then
10222 #ifdef MOMENT
10223         s1=dipderg(3,jj,i)*dip(1,kk,k)
10224 #endif
10225         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10226         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10227         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10228         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10229         vv(1)=pizda(1,1)-pizda(2,2)
10230         vv(2)=pizda(1,2)+pizda(2,1)
10231         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10232 #ifdef MOMENT
10233         if (swap) then
10234           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10235         else
10236           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10237         endif
10238 #endif
10239         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10240 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10241       endif
10242 ! Derivatives in gamma(l-1) or gamma(j-1)
10243       if (l.gt.1) then
10244 #ifdef MOMENT
10245         s1=dip(1,jj,i)*dipderg(3,kk,k)
10246 #endif
10247         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10248         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10249         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10250         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10251         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10252         vv(1)=pizda(1,1)-pizda(2,2)
10253         vv(2)=pizda(1,2)+pizda(2,1)
10254         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10255 #ifdef MOMENT
10256         if (swap) then
10257           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10258         else
10259           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10260         endif
10261 #endif
10262         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10263 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10264       endif
10265 ! Cartesian derivatives.
10266       if (lprn) then
10267         write (2,*) 'In eello6_graph2'
10268         do iii=1,2
10269           write (2,*) 'iii=',iii
10270           do kkk=1,5
10271             write (2,*) 'kkk=',kkk
10272             do jjj=1,2
10273               write (2,'(3(2f10.5),5x)') &
10274               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10275             enddo
10276           enddo
10277         enddo
10278       endif
10279       do iii=1,2
10280         do kkk=1,5
10281           do lll=1,3
10282 #ifdef MOMENT
10283             if (iii.eq.1) then
10284               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10285             else
10286               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10287             endif
10288 #endif
10289             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10290               auxvec(1))
10291             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10292             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10293               auxvec(1))
10294             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10295             call transpose2(EUg(1,1,k),auxmat(1,1))
10296             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10297               pizda(1,1))
10298             vv(1)=pizda(1,1)-pizda(2,2)
10299             vv(2)=pizda(1,2)+pizda(2,1)
10300             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10301 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10302 #ifdef MOMENT
10303             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10304 #else
10305             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10306 #endif
10307             if (swap) then
10308               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10309             else
10310               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10311             endif
10312           enddo
10313         enddo
10314       enddo
10315       return
10316       end function eello6_graph2
10317 !-----------------------------------------------------------------------------
10318       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10319 !      implicit real*8 (a-h,o-z)
10320 !      include 'DIMENSIONS'
10321 !      include 'COMMON.IOUNITS'
10322 !      include 'COMMON.CHAIN'
10323 !      include 'COMMON.DERIV'
10324 !      include 'COMMON.INTERACT'
10325 !      include 'COMMON.CONTACTS'
10326 !      include 'COMMON.TORSION'
10327 !      include 'COMMON.VAR'
10328 !      include 'COMMON.GEO'
10329       real(kind=8),dimension(2) :: vv,auxvec
10330       real(kind=8),dimension(2,2) :: pizda,auxmat
10331       logical :: swap
10332       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10333       real(kind=8) :: s1,s2,s3,s4
10334 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10335 !                                                                              C
10336 !      Parallel       Antiparallel                                             C
10337 !                                                                              C
10338 !          o             o                                                     C
10339 !         /l\   /   \   /j\                                                    C
10340 !        /   \ /     \ /   \                                                   C
10341 !       /| o |o       o| o |\                                                  C
10342 !       j|/k\|  /      |/k\|l /                                                C
10343 !        /   \ /       /   \ /                                                 C
10344 !       /     o       /     o                                                  C
10345 !       i             i                                                        C
10346 !                                                                              C
10347 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10348 !
10349 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10350 !           energy moment and not to the cluster cumulant.
10351       iti=itortyp(itype(i,1))
10352       if (j.lt.nres-1) then
10353         itj1=itortyp(itype(j+1,1))
10354       else
10355         itj1=ntortyp+1
10356       endif
10357       itk=itortyp(itype(k,1))
10358       itk1=itortyp(itype(k+1,1))
10359       if (l.lt.nres-1) then
10360         itl1=itortyp(itype(l+1,1))
10361       else
10362         itl1=ntortyp+1
10363       endif
10364 #ifdef MOMENT
10365       s1=dip(4,jj,i)*dip(4,kk,k)
10366 #endif
10367       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10368       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10369       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10370       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10371       call transpose2(EE(1,1,itk),auxmat(1,1))
10372       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10373       vv(1)=pizda(1,1)+pizda(2,2)
10374       vv(2)=pizda(2,1)-pizda(1,2)
10375       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10376 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10377 !d     & "sum",-(s2+s3+s4)
10378 #ifdef MOMENT
10379       eello6_graph3=-(s1+s2+s3+s4)
10380 #else
10381       eello6_graph3=-(s2+s3+s4)
10382 #endif
10383 !      eello6_graph3=-s4
10384 ! Derivatives in gamma(k-1)
10385       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10386       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10387       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10388       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10389 ! Derivatives in gamma(l-1)
10390       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10391       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10392       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10393       vv(1)=pizda(1,1)+pizda(2,2)
10394       vv(2)=pizda(2,1)-pizda(1,2)
10395       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10396       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10397 ! Cartesian derivatives.
10398       do iii=1,2
10399         do kkk=1,5
10400           do lll=1,3
10401 #ifdef MOMENT
10402             if (iii.eq.1) then
10403               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10404             else
10405               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10406             endif
10407 #endif
10408             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10409               auxvec(1))
10410             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10411             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10412               auxvec(1))
10413             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10414             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10415               pizda(1,1))
10416             vv(1)=pizda(1,1)+pizda(2,2)
10417             vv(2)=pizda(2,1)-pizda(1,2)
10418             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10419 #ifdef MOMENT
10420             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10421 #else
10422             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10423 #endif
10424             if (swap) then
10425               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10426             else
10427               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10428             endif
10429 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10430           enddo
10431         enddo
10432       enddo
10433       return
10434       end function eello6_graph3
10435 !-----------------------------------------------------------------------------
10436       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10437 !      implicit real*8 (a-h,o-z)
10438 !      include 'DIMENSIONS'
10439 !      include 'COMMON.IOUNITS'
10440 !      include 'COMMON.CHAIN'
10441 !      include 'COMMON.DERIV'
10442 !      include 'COMMON.INTERACT'
10443 !      include 'COMMON.CONTACTS'
10444 !      include 'COMMON.TORSION'
10445 !      include 'COMMON.VAR'
10446 !      include 'COMMON.GEO'
10447 !      include 'COMMON.FFIELD'
10448       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10449       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10450       logical :: swap
10451       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10452               iii,kkk,lll
10453       real(kind=8) :: s1,s2,s3,s4
10454 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10455 !                                                                              C
10456 !      Parallel       Antiparallel                                             C
10457 !                                                                              C
10458 !          o             o                                                     C
10459 !         /l\   /   \   /j\                                                    C
10460 !        /   \ /     \ /   \                                                   C
10461 !       /| o |o       o| o |\                                                  C
10462 !     \ j|/k\|      \  |/k\|l                                                  C
10463 !      \ /   \       \ /   \                                                   C
10464 !       o     \       o     \                                                  C
10465 !       i             i                                                        C
10466 !                                                                              C
10467 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10468 !
10469 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10470 !           energy moment and not to the cluster cumulant.
10471 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10472       iti=itortyp(itype(i,1))
10473       itj=itortyp(itype(j,1))
10474       if (j.lt.nres-1) then
10475         itj1=itortyp(itype(j+1,1))
10476       else
10477         itj1=ntortyp+1
10478       endif
10479       itk=itortyp(itype(k,1))
10480       if (k.lt.nres-1) then
10481         itk1=itortyp(itype(k+1,1))
10482       else
10483         itk1=ntortyp+1
10484       endif
10485       itl=itortyp(itype(l,1))
10486       if (l.lt.nres-1) then
10487         itl1=itortyp(itype(l+1,1))
10488       else
10489         itl1=ntortyp+1
10490       endif
10491 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10492 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10493 !d     & ' itl',itl,' itl1',itl1
10494 #ifdef MOMENT
10495       if (imat.eq.1) then
10496         s1=dip(3,jj,i)*dip(3,kk,k)
10497       else
10498         s1=dip(2,jj,j)*dip(2,kk,l)
10499       endif
10500 #endif
10501       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10502       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10503       if (j.eq.l+1) then
10504         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10505         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10506       else
10507         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10508         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10509       endif
10510       call transpose2(EUg(1,1,k),auxmat(1,1))
10511       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10512       vv(1)=pizda(1,1)-pizda(2,2)
10513       vv(2)=pizda(2,1)+pizda(1,2)
10514       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10515 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10516 #ifdef MOMENT
10517       eello6_graph4=-(s1+s2+s3+s4)
10518 #else
10519       eello6_graph4=-(s2+s3+s4)
10520 #endif
10521 ! Derivatives in gamma(i-1)
10522       if (i.gt.1) then
10523 #ifdef MOMENT
10524         if (imat.eq.1) then
10525           s1=dipderg(2,jj,i)*dip(3,kk,k)
10526         else
10527           s1=dipderg(4,jj,j)*dip(2,kk,l)
10528         endif
10529 #endif
10530         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10531         if (j.eq.l+1) then
10532           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10533           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10534         else
10535           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10536           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10537         endif
10538         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10539         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10540 !d          write (2,*) 'turn6 derivatives'
10541 #ifdef MOMENT
10542           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10543 #else
10544           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10545 #endif
10546         else
10547 #ifdef MOMENT
10548           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10549 #else
10550           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10551 #endif
10552         endif
10553       endif
10554 ! Derivatives in gamma(k-1)
10555 #ifdef MOMENT
10556       if (imat.eq.1) then
10557         s1=dip(3,jj,i)*dipderg(2,kk,k)
10558       else
10559         s1=dip(2,jj,j)*dipderg(4,kk,l)
10560       endif
10561 #endif
10562       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10563       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10564       if (j.eq.l+1) then
10565         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10566         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10567       else
10568         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10569         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10570       endif
10571       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10572       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10573       vv(1)=pizda(1,1)-pizda(2,2)
10574       vv(2)=pizda(2,1)+pizda(1,2)
10575       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10576       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10577 #ifdef MOMENT
10578         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10579 #else
10580         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10581 #endif
10582       else
10583 #ifdef MOMENT
10584         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10585 #else
10586         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10587 #endif
10588       endif
10589 ! Derivatives in gamma(j-1) or gamma(l-1)
10590       if (l.eq.j+1 .and. l.gt.1) then
10591         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10592         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10593         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10594         vv(1)=pizda(1,1)-pizda(2,2)
10595         vv(2)=pizda(2,1)+pizda(1,2)
10596         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10597         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10598       else if (j.gt.1) then
10599         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10600         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10601         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10602         vv(1)=pizda(1,1)-pizda(2,2)
10603         vv(2)=pizda(2,1)+pizda(1,2)
10604         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10605         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10606           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10607         else
10608           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10609         endif
10610       endif
10611 ! Cartesian derivatives.
10612       do iii=1,2
10613         do kkk=1,5
10614           do lll=1,3
10615 #ifdef MOMENT
10616             if (iii.eq.1) then
10617               if (imat.eq.1) then
10618                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10619               else
10620                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10621               endif
10622             else
10623               if (imat.eq.1) then
10624                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10625               else
10626                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10627               endif
10628             endif
10629 #endif
10630             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10631               auxvec(1))
10632             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10633             if (j.eq.l+1) then
10634               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10635                 b1(1,itj1),auxvec(1))
10636               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10637             else
10638               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10639                 b1(1,itl1),auxvec(1))
10640               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10641             endif
10642             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10643               pizda(1,1))
10644             vv(1)=pizda(1,1)-pizda(2,2)
10645             vv(2)=pizda(2,1)+pizda(1,2)
10646             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10647             if (swap) then
10648               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10649 #ifdef MOMENT
10650                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10651                    -(s1+s2+s4)
10652 #else
10653                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10654                    -(s2+s4)
10655 #endif
10656                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10657               else
10658 #ifdef MOMENT
10659                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10660 #else
10661                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10662 #endif
10663                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10664               endif
10665             else
10666 #ifdef MOMENT
10667               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10668 #else
10669               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10670 #endif
10671               if (l.eq.j+1) then
10672                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10673               else
10674                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10675               endif
10676             endif
10677           enddo
10678         enddo
10679       enddo
10680       return
10681       end function eello6_graph4
10682 !-----------------------------------------------------------------------------
10683       real(kind=8) function eello_turn6(i,jj,kk)
10684 !      implicit real*8 (a-h,o-z)
10685 !      include 'DIMENSIONS'
10686 !      include 'COMMON.IOUNITS'
10687 !      include 'COMMON.CHAIN'
10688 !      include 'COMMON.DERIV'
10689 !      include 'COMMON.INTERACT'
10690 !      include 'COMMON.CONTACTS'
10691 !      include 'COMMON.TORSION'
10692 !      include 'COMMON.VAR'
10693 !      include 'COMMON.GEO'
10694       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10695       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10696       real(kind=8),dimension(3) :: ggg1,ggg2
10697       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10698       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10699 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10700 !           the respective energy moment and not to the cluster cumulant.
10701 !el local variables
10702       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10703       integer :: j1,j2,l1,l2,ll
10704       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10705       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10706       s1=0.0d0
10707       s8=0.0d0
10708       s13=0.0d0
10709 !
10710       eello_turn6=0.0d0
10711       j=i+4
10712       k=i+1
10713       l=i+3
10714       iti=itortyp(itype(i,1))
10715       itk=itortyp(itype(k,1))
10716       itk1=itortyp(itype(k+1,1))
10717       itl=itortyp(itype(l,1))
10718       itj=itortyp(itype(j,1))
10719 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10720 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10721 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10722 !d        eello6=0.0d0
10723 !d        return
10724 !d      endif
10725 !d      write (iout,*)
10726 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10727 !d     &   ' and',k,l
10728 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10729       do iii=1,2
10730         do kkk=1,5
10731           do lll=1,3
10732             derx_turn(lll,kkk,iii)=0.0d0
10733           enddo
10734         enddo
10735       enddo
10736 !d      eij=1.0d0
10737 !d      ekl=1.0d0
10738 !d      ekont=1.0d0
10739       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10740 !d      eello6_5=0.0d0
10741 !d      write (2,*) 'eello6_5',eello6_5
10742 #ifdef MOMENT
10743       call transpose2(AEA(1,1,1),auxmat(1,1))
10744       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10745       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10746       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10747 #endif
10748       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10749       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10750       s2 = scalar2(b1(1,itk),vtemp1(1))
10751 #ifdef MOMENT
10752       call transpose2(AEA(1,1,2),atemp(1,1))
10753       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10754       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10755       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10756 #endif
10757       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10758       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10759       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10760 #ifdef MOMENT
10761       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10762       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10763       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10764       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10765       ss13 = scalar2(b1(1,itk),vtemp4(1))
10766       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10767 #endif
10768 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10769 !      s1=0.0d0
10770 !      s2=0.0d0
10771 !      s8=0.0d0
10772 !      s12=0.0d0
10773 !      s13=0.0d0
10774       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10775 ! Derivatives in gamma(i+2)
10776       s1d =0.0d0
10777       s8d =0.0d0
10778 #ifdef MOMENT
10779       call transpose2(AEA(1,1,1),auxmatd(1,1))
10780       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10781       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10782       call transpose2(AEAderg(1,1,2),atempd(1,1))
10783       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10784       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10785 #endif
10786       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10787       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10788       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10789 !      s1d=0.0d0
10790 !      s2d=0.0d0
10791 !      s8d=0.0d0
10792 !      s12d=0.0d0
10793 !      s13d=0.0d0
10794       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10795 ! Derivatives in gamma(i+3)
10796 #ifdef MOMENT
10797       call transpose2(AEA(1,1,1),auxmatd(1,1))
10798       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10799       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10800       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10801 #endif
10802       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10803       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10804       s2d = scalar2(b1(1,itk),vtemp1d(1))
10805 #ifdef MOMENT
10806       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10807       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10808 #endif
10809       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10810 #ifdef MOMENT
10811       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10812       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10813       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10814 #endif
10815 !      s1d=0.0d0
10816 !      s2d=0.0d0
10817 !      s8d=0.0d0
10818 !      s12d=0.0d0
10819 !      s13d=0.0d0
10820 #ifdef MOMENT
10821       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10822                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10823 #else
10824       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10825                     -0.5d0*ekont*(s2d+s12d)
10826 #endif
10827 ! Derivatives in gamma(i+4)
10828       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10829       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10830       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10831 #ifdef MOMENT
10832       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10833       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10834       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10835 #endif
10836 !      s1d=0.0d0
10837 !      s2d=0.0d0
10838 !      s8d=0.0d0
10839 !      s12d=0.0d0
10840 !      s13d=0.0d0
10841 #ifdef MOMENT
10842       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10843 #else
10844       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10845 #endif
10846 ! Derivatives in gamma(i+5)
10847 #ifdef MOMENT
10848       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10849       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10850       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10851 #endif
10852       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10853       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10854       s2d = scalar2(b1(1,itk),vtemp1d(1))
10855 #ifdef MOMENT
10856       call transpose2(AEA(1,1,2),atempd(1,1))
10857       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10858       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10859 #endif
10860       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10861       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10862 #ifdef MOMENT
10863       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10864       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10865       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10866 #endif
10867 !      s1d=0.0d0
10868 !      s2d=0.0d0
10869 !      s8d=0.0d0
10870 !      s12d=0.0d0
10871 !      s13d=0.0d0
10872 #ifdef MOMENT
10873       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10874                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10875 #else
10876       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10877                     -0.5d0*ekont*(s2d+s12d)
10878 #endif
10879 ! Cartesian derivatives
10880       do iii=1,2
10881         do kkk=1,5
10882           do lll=1,3
10883 #ifdef MOMENT
10884             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10885             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10886             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10887 #endif
10888             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10889             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10890                 vtemp1d(1))
10891             s2d = scalar2(b1(1,itk),vtemp1d(1))
10892 #ifdef MOMENT
10893             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10894             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10895             s8d = -(atempd(1,1)+atempd(2,2))* &
10896                  scalar2(cc(1,1,itl),vtemp2(1))
10897 #endif
10898             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10899                  auxmatd(1,1))
10900             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10901             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10902 !      s1d=0.0d0
10903 !      s2d=0.0d0
10904 !      s8d=0.0d0
10905 !      s12d=0.0d0
10906 !      s13d=0.0d0
10907 #ifdef MOMENT
10908             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10909               - 0.5d0*(s1d+s2d)
10910 #else
10911             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10912               - 0.5d0*s2d
10913 #endif
10914 #ifdef MOMENT
10915             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10916               - 0.5d0*(s8d+s12d)
10917 #else
10918             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10919               - 0.5d0*s12d
10920 #endif
10921           enddo
10922         enddo
10923       enddo
10924 #ifdef MOMENT
10925       do kkk=1,5
10926         do lll=1,3
10927           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10928             achuj_tempd(1,1))
10929           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10930           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10931           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10932           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10933           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10934             vtemp4d(1))
10935           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10936           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10937           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10938         enddo
10939       enddo
10940 #endif
10941 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10942 !d     &  16*eel_turn6_num
10943 !d      goto 1112
10944       if (j.lt.nres-1) then
10945         j1=j+1
10946         j2=j-1
10947       else
10948         j1=j-1
10949         j2=j-2
10950       endif
10951       if (l.lt.nres-1) then
10952         l1=l+1
10953         l2=l-1
10954       else
10955         l1=l-1
10956         l2=l-2
10957       endif
10958       do ll=1,3
10959 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10960 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10961 !grad        ghalf=0.5d0*ggg1(ll)
10962 !d        ghalf=0.0d0
10963         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10964         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10965         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10966           +ekont*derx_turn(ll,2,1)
10967         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10968         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10969           +ekont*derx_turn(ll,4,1)
10970         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10971         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10972         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10973 !grad        ghalf=0.5d0*ggg2(ll)
10974 !d        ghalf=0.0d0
10975         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10976           +ekont*derx_turn(ll,2,2)
10977         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10978         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10979           +ekont*derx_turn(ll,4,2)
10980         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10981         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10982         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10983       enddo
10984 !d      goto 1112
10985 !grad      do m=i+1,j-1
10986 !grad        do ll=1,3
10987 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10988 !grad        enddo
10989 !grad      enddo
10990 !grad      do m=k+1,l-1
10991 !grad        do ll=1,3
10992 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10993 !grad        enddo
10994 !grad      enddo
10995 !grad1112  continue
10996 !grad      do m=i+2,j2
10997 !grad        do ll=1,3
10998 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10999 !grad        enddo
11000 !grad      enddo
11001 !grad      do m=k+2,l2
11002 !grad        do ll=1,3
11003 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11004 !grad        enddo
11005 !grad      enddo
11006 !d      do iii=1,nres-3
11007 !d        write (2,*) iii,g_corr6_loc(iii)
11008 !d      enddo
11009       eello_turn6=ekont*eel_turn6
11010 !d      write (2,*) 'ekont',ekont
11011 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11012       return
11013       end function eello_turn6
11014 !-----------------------------------------------------------------------------
11015       subroutine MATVEC2(A1,V1,V2)
11016 !DIR$ INLINEALWAYS MATVEC2
11017 #ifndef OSF
11018 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11019 #endif
11020 !      implicit real*8 (a-h,o-z)
11021 !      include 'DIMENSIONS'
11022       real(kind=8),dimension(2) :: V1,V2
11023       real(kind=8),dimension(2,2) :: A1
11024       real(kind=8) :: vaux1,vaux2
11025 !      DO 1 I=1,2
11026 !        VI=0.0
11027 !        DO 3 K=1,2
11028 !    3     VI=VI+A1(I,K)*V1(K)
11029 !        Vaux(I)=VI
11030 !    1 CONTINUE
11031
11032       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11033       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11034
11035       v2(1)=vaux1
11036       v2(2)=vaux2
11037       end subroutine MATVEC2
11038 !-----------------------------------------------------------------------------
11039       subroutine MATMAT2(A1,A2,A3)
11040 #ifndef OSF
11041 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11042 #endif
11043 !      implicit real*8 (a-h,o-z)
11044 !      include 'DIMENSIONS'
11045       real(kind=8),dimension(2,2) :: A1,A2,A3
11046       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11047 !      DIMENSION AI3(2,2)
11048 !        DO  J=1,2
11049 !          A3IJ=0.0
11050 !          DO K=1,2
11051 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11052 !          enddo
11053 !          A3(I,J)=A3IJ
11054 !       enddo
11055 !      enddo
11056
11057       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11058       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11059       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11060       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11061
11062       A3(1,1)=AI3_11
11063       A3(2,1)=AI3_21
11064       A3(1,2)=AI3_12
11065       A3(2,2)=AI3_22
11066       end subroutine MATMAT2
11067 !-----------------------------------------------------------------------------
11068       real(kind=8) function scalar2(u,v)
11069 !DIR$ INLINEALWAYS scalar2
11070       implicit none
11071       real(kind=8),dimension(2) :: u,v
11072       real(kind=8) :: sc
11073       integer :: i
11074       scalar2=u(1)*v(1)+u(2)*v(2)
11075       return
11076       end function scalar2
11077 !-----------------------------------------------------------------------------
11078       subroutine transpose2(a,at)
11079 !DIR$ INLINEALWAYS transpose2
11080 #ifndef OSF
11081 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11082 #endif
11083       implicit none
11084       real(kind=8),dimension(2,2) :: a,at
11085       at(1,1)=a(1,1)
11086       at(1,2)=a(2,1)
11087       at(2,1)=a(1,2)
11088       at(2,2)=a(2,2)
11089       return
11090       end subroutine transpose2
11091 !-----------------------------------------------------------------------------
11092       subroutine transpose(n,a,at)
11093       implicit none
11094       integer :: n,i,j
11095       real(kind=8),dimension(n,n) :: a,at
11096       do i=1,n
11097         do j=1,n
11098           at(j,i)=a(i,j)
11099         enddo
11100       enddo
11101       return
11102       end subroutine transpose
11103 !-----------------------------------------------------------------------------
11104       subroutine prodmat3(a1,a2,kk,transp,prod)
11105 !DIR$ INLINEALWAYS prodmat3
11106 #ifndef OSF
11107 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11108 #endif
11109       implicit none
11110       integer :: i,j
11111       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11112       logical :: transp
11113 !rc      double precision auxmat(2,2),prod_(2,2)
11114
11115       if (transp) then
11116 !rc        call transpose2(kk(1,1),auxmat(1,1))
11117 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11118 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11119
11120            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11121        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11122            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11123        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11124            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11125        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11126            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11127        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11128
11129       else
11130 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11131 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11132
11133            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11134         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11135            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11136         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11137            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11138         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11139            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11140         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11141
11142       endif
11143 !      call transpose2(a2(1,1),a2t(1,1))
11144
11145 !rc      print *,transp
11146 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11147 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11148
11149       return
11150       end subroutine prodmat3
11151 !-----------------------------------------------------------------------------
11152 ! energy_p_new_barrier.F
11153 !-----------------------------------------------------------------------------
11154       subroutine sum_gradient
11155 !      implicit real*8 (a-h,o-z)
11156       use io_base, only: pdbout
11157 !      include 'DIMENSIONS'
11158 #ifndef ISNAN
11159       external proc_proc
11160 #ifdef WINPGI
11161 !MS$ATTRIBUTES C ::  proc_proc
11162 #endif
11163 #endif
11164 #ifdef MPI
11165       include 'mpif.h'
11166 #endif
11167       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11168                    gloc_scbuf !(3,maxres)
11169
11170       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11171 !#endif
11172 !el local variables
11173       integer :: i,j,k,ierror,ierr
11174       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11175                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11176                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11177                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11178                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11179                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11180                    gsccorr_max,gsccorrx_max,time00
11181
11182 !      include 'COMMON.SETUP'
11183 !      include 'COMMON.IOUNITS'
11184 !      include 'COMMON.FFIELD'
11185 !      include 'COMMON.DERIV'
11186 !      include 'COMMON.INTERACT'
11187 !      include 'COMMON.SBRIDGE'
11188 !      include 'COMMON.CHAIN'
11189 !      include 'COMMON.VAR'
11190 !      include 'COMMON.CONTROL'
11191 !      include 'COMMON.TIME1'
11192 !      include 'COMMON.MAXGRAD'
11193 !      include 'COMMON.SCCOR'
11194 #ifdef TIMING
11195       time01=MPI_Wtime()
11196 #endif
11197 #ifdef DEBUG
11198       write (iout,*) "sum_gradient gvdwc, gvdwx"
11199       do i=1,nres
11200         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11201          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11202       enddo
11203       call flush(iout)
11204 #endif
11205 #ifdef MPI
11206         gradbufc=0.0d0
11207         gradbufx=0.0d0
11208         gradbufc_sum=0.0d0
11209         gloc_scbuf=0.0d0
11210         glocbuf=0.0d0
11211 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11212         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11213           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11214 #endif
11215 !
11216 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11217 !            in virtual-bond-vector coordinates
11218 !
11219 #ifdef DEBUG
11220 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11221 !      do i=1,nres-1
11222 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11223 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11224 !      enddo
11225 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11226 !      do i=1,nres-1
11227 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11228 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11229 !      enddo
11230       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11231       do i=1,nres
11232         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11233          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11234          (gvdwc_scpp(j,i),j=1,3)
11235       enddo
11236       write (iout,*) "gelc_long gvdwpp gel_loc_long"
11237       do i=1,nres
11238         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11239          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11240          (gelc_loc_long(j,i),j=1,3)
11241       enddo
11242       call flush(iout)
11243 #endif
11244 #ifdef SPLITELE
11245       do i=0,nct
11246         do j=1,3
11247           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11248                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11249                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11250                       wel_loc*gel_loc_long(j,i)+ &
11251                       wcorr*gradcorr_long(j,i)+ &
11252                       wcorr5*gradcorr5_long(j,i)+ &
11253                       wcorr6*gradcorr6_long(j,i)+ &
11254                       wturn6*gcorr6_turn_long(j,i)+ &
11255                       wstrain*ghpbc(j,i) &
11256                      +wliptran*gliptranc(j,i) &
11257                      +gradafm(j,i) &
11258                      +welec*gshieldc(j,i) &
11259                      +wcorr*gshieldc_ec(j,i) &
11260                      +wturn3*gshieldc_t3(j,i)&
11261                      +wturn4*gshieldc_t4(j,i)&
11262                      +wel_loc*gshieldc_ll(j,i)&
11263                      +wtube*gg_tube(j,i) &
11264                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11265                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11266                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11267                      wcorr_nucl*gradcorr_nucl(j,i)&
11268                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11269                      wcatprot* gradpepcat(j,i)+ &
11270                      wcatcat*gradcatcat(j,i)+   &
11271                      wscbase*gvdwc_scbase(j,i)+ &
11272                      wpepbase*gvdwc_pepbase(j,i)+&
11273                      wscpho*gvdwc_scpho(j,i)+   &
11274                      wpeppho*gvdwc_peppho(j,i)
11275
11276
11277
11278
11279
11280         enddo
11281       enddo
11282 #else
11283       do i=0,nct
11284         do j=1,3
11285           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11286                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11287                       welec*gelc_long(j,i)+ &
11288                       wbond*gradb(j,i)+ &
11289                       wel_loc*gel_loc_long(j,i)+ &
11290                       wcorr*gradcorr_long(j,i)+ &
11291                       wcorr5*gradcorr5_long(j,i)+ &
11292                       wcorr6*gradcorr6_long(j,i)+ &
11293                       wturn6*gcorr6_turn_long(j,i)+ &
11294                       wstrain*ghpbc(j,i) &
11295                      +wliptran*gliptranc(j,i) &
11296                      +gradafm(j,i) &
11297                      +welec*gshieldc(j,i)&
11298                      +wcorr*gshieldc_ec(j,i) &
11299                      +wturn4*gshieldc_t4(j,i) &
11300                      +wel_loc*gshieldc_ll(j,i)&
11301                      +wtube*gg_tube(j,i) &
11302                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11303                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11304                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11305                      wcorr_nucl*gradcorr_nucl(j,i) &
11306                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11307                      wcatprot* gradpepcat(j,i)+ &
11308                      wcatcat*gradcatcat(j,i)+   &
11309                      wscbase*gvdwc_scbase(j,i)  &
11310                      wpepbase*gvdwc_pepbase(j,i)+&
11311                      wscpho*gvdwc_scpho(j,i)+&
11312                      wpeppho*gvdwc_peppho(j,i)
11313
11314
11315         enddo
11316       enddo
11317 #endif
11318 #ifdef MPI
11319       if (nfgtasks.gt.1) then
11320       time00=MPI_Wtime()
11321 #ifdef DEBUG
11322       write (iout,*) "gradbufc before allreduce"
11323       do i=1,nres
11324         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11325       enddo
11326       call flush(iout)
11327 #endif
11328       do i=0,nres
11329         do j=1,3
11330           gradbufc_sum(j,i)=gradbufc(j,i)
11331         enddo
11332       enddo
11333 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11334 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11335 !      time_reduce=time_reduce+MPI_Wtime()-time00
11336 #ifdef DEBUG
11337 !      write (iout,*) "gradbufc_sum after allreduce"
11338 !      do i=1,nres
11339 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11340 !      enddo
11341 !      call flush(iout)
11342 #endif
11343 #ifdef TIMING
11344 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11345 #endif
11346       do i=0,nres
11347         do k=1,3
11348           gradbufc(k,i)=0.0d0
11349         enddo
11350       enddo
11351 #ifdef DEBUG
11352       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11353       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11354                         " jgrad_end  ",jgrad_end(i),&
11355                         i=igrad_start,igrad_end)
11356 #endif
11357 !
11358 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11359 ! do not parallelize this part.
11360 !
11361 !      do i=igrad_start,igrad_end
11362 !        do j=jgrad_start(i),jgrad_end(i)
11363 !          do k=1,3
11364 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11365 !          enddo
11366 !        enddo
11367 !      enddo
11368       do j=1,3
11369         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11370       enddo
11371       do i=nres-2,-1,-1
11372         do j=1,3
11373           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11374         enddo
11375       enddo
11376 #ifdef DEBUG
11377       write (iout,*) "gradbufc after summing"
11378       do i=1,nres
11379         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11380       enddo
11381       call flush(iout)
11382 #endif
11383       else
11384 #endif
11385 !el#define DEBUG
11386 #ifdef DEBUG
11387       write (iout,*) "gradbufc"
11388       do i=1,nres
11389         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11390       enddo
11391       call flush(iout)
11392 #endif
11393 !el#undef DEBUG
11394       do i=-1,nres
11395         do j=1,3
11396           gradbufc_sum(j,i)=gradbufc(j,i)
11397           gradbufc(j,i)=0.0d0
11398         enddo
11399       enddo
11400       do j=1,3
11401         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11402       enddo
11403       do i=nres-2,-1,-1
11404         do j=1,3
11405           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11406         enddo
11407       enddo
11408 !      do i=nnt,nres-1
11409 !        do k=1,3
11410 !          gradbufc(k,i)=0.0d0
11411 !        enddo
11412 !        do j=i+1,nres
11413 !          do k=1,3
11414 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11415 !          enddo
11416 !        enddo
11417 !      enddo
11418 !el#define DEBUG
11419 #ifdef DEBUG
11420       write (iout,*) "gradbufc after summing"
11421       do i=1,nres
11422         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11423       enddo
11424       call flush(iout)
11425 #endif
11426 !el#undef DEBUG
11427 #ifdef MPI
11428       endif
11429 #endif
11430       do k=1,3
11431         gradbufc(k,nres)=0.0d0
11432       enddo
11433 !el----------------
11434 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11435 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11436 !el-----------------
11437       do i=-1,nct
11438         do j=1,3
11439 #ifdef SPLITELE
11440           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11441                       wel_loc*gel_loc(j,i)+ &
11442                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11443                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11444                       wel_loc*gel_loc_long(j,i)+ &
11445                       wcorr*gradcorr_long(j,i)+ &
11446                       wcorr5*gradcorr5_long(j,i)+ &
11447                       wcorr6*gradcorr6_long(j,i)+ &
11448                       wturn6*gcorr6_turn_long(j,i))+ &
11449                       wbond*gradb(j,i)+ &
11450                       wcorr*gradcorr(j,i)+ &
11451                       wturn3*gcorr3_turn(j,i)+ &
11452                       wturn4*gcorr4_turn(j,i)+ &
11453                       wcorr5*gradcorr5(j,i)+ &
11454                       wcorr6*gradcorr6(j,i)+ &
11455                       wturn6*gcorr6_turn(j,i)+ &
11456                       wsccor*gsccorc(j,i) &
11457                      +wscloc*gscloc(j,i)  &
11458                      +wliptran*gliptranc(j,i) &
11459                      +gradafm(j,i) &
11460                      +welec*gshieldc(j,i) &
11461                      +welec*gshieldc_loc(j,i) &
11462                      +wcorr*gshieldc_ec(j,i) &
11463                      +wcorr*gshieldc_loc_ec(j,i) &
11464                      +wturn3*gshieldc_t3(j,i) &
11465                      +wturn3*gshieldc_loc_t3(j,i) &
11466                      +wturn4*gshieldc_t4(j,i) &
11467                      +wturn4*gshieldc_loc_t4(j,i) &
11468                      +wel_loc*gshieldc_ll(j,i) &
11469                      +wel_loc*gshieldc_loc_ll(j,i) &
11470                      +wtube*gg_tube(j,i) &
11471                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11472                      +wvdwpsb*gvdwpsb1(j,i))&
11473                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11474 !                      if (i.eq.21) then
11475 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11476 !                      wturn4*gshieldc_t4(j,i), &
11477 !                     wturn4*gshieldc_loc_t4(j,i)
11478 !                       endif
11479 !                 if ((i.le.2).and.(i.ge.1))
11480 !                       print *,gradc(j,i,icg),&
11481 !                      gradbufc(j,i),welec*gelc(j,i), &
11482 !                      wel_loc*gel_loc(j,i), &
11483 !                      wscp*gvdwc_scpp(j,i), &
11484 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11485 !                      wel_loc*gel_loc_long(j,i), &
11486 !                      wcorr*gradcorr_long(j,i), &
11487 !                      wcorr5*gradcorr5_long(j,i), &
11488 !                      wcorr6*gradcorr6_long(j,i), &
11489 !                      wturn6*gcorr6_turn_long(j,i), &
11490 !                      wbond*gradb(j,i), &
11491 !                      wcorr*gradcorr(j,i), &
11492 !                      wturn3*gcorr3_turn(j,i), &
11493 !                      wturn4*gcorr4_turn(j,i), &
11494 !                      wcorr5*gradcorr5(j,i), &
11495 !                      wcorr6*gradcorr6(j,i), &
11496 !                      wturn6*gcorr6_turn(j,i), &
11497 !                      wsccor*gsccorc(j,i) &
11498 !                     ,wscloc*gscloc(j,i)  &
11499 !                     ,wliptran*gliptranc(j,i) &
11500 !                    ,gradafm(j,i) &
11501 !                     ,welec*gshieldc(j,i) &
11502 !                     ,welec*gshieldc_loc(j,i) &
11503 !                     ,wcorr*gshieldc_ec(j,i) &
11504 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11505 !                     ,wturn3*gshieldc_t3(j,i) &
11506 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11507 !                     ,wturn4*gshieldc_t4(j,i) &
11508 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11509 !                     ,wel_loc*gshieldc_ll(j,i) &
11510 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11511 !                     ,wtube*gg_tube(j,i) &
11512 !                     ,wbond_nucl*gradb_nucl(j,i) &
11513 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11514 !                     wvdwpsb*gvdwpsb1(j,i)&
11515 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11516 !
11517
11518 #else
11519           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11520                       wel_loc*gel_loc(j,i)+ &
11521                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11522                       welec*gelc_long(j,i)+ &
11523                       wel_loc*gel_loc_long(j,i)+ &
11524 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11525                       wcorr5*gradcorr5_long(j,i)+ &
11526                       wcorr6*gradcorr6_long(j,i)+ &
11527                       wturn6*gcorr6_turn_long(j,i))+ &
11528                       wbond*gradb(j,i)+ &
11529                       wcorr*gradcorr(j,i)+ &
11530                       wturn3*gcorr3_turn(j,i)+ &
11531                       wturn4*gcorr4_turn(j,i)+ &
11532                       wcorr5*gradcorr5(j,i)+ &
11533                       wcorr6*gradcorr6(j,i)+ &
11534                       wturn6*gcorr6_turn(j,i)+ &
11535                       wsccor*gsccorc(j,i) &
11536                      +wscloc*gscloc(j,i) &
11537                      +gradafm(j,i) &
11538                      +wliptran*gliptranc(j,i) &
11539                      +welec*gshieldc(j,i) &
11540                      +welec*gshieldc_loc(j,) &
11541                      +wcorr*gshieldc_ec(j,i) &
11542                      +wcorr*gshieldc_loc_ec(j,i) &
11543                      +wturn3*gshieldc_t3(j,i) &
11544                      +wturn3*gshieldc_loc_t3(j,i) &
11545                      +wturn4*gshieldc_t4(j,i) &
11546                      +wturn4*gshieldc_loc_t4(j,i) &
11547                      +wel_loc*gshieldc_ll(j,i) &
11548                      +wel_loc*gshieldc_loc_ll(j,i) &
11549                      +wtube*gg_tube(j,i) &
11550                      +wbond_nucl*gradb_nucl(j,i) &
11551                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11552                      +wvdwpsb*gvdwpsb1(j,i))&
11553                      +wsbloc*gsbloc(j,i)
11554
11555
11556
11557
11558 #endif
11559           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11560                         wbond*gradbx(j,i)+ &
11561                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11562                         wsccor*gsccorx(j,i) &
11563                        +wscloc*gsclocx(j,i) &
11564                        +wliptran*gliptranx(j,i) &
11565                        +welec*gshieldx(j,i)     &
11566                        +wcorr*gshieldx_ec(j,i)  &
11567                        +wturn3*gshieldx_t3(j,i) &
11568                        +wturn4*gshieldx_t4(j,i) &
11569                        +wel_loc*gshieldx_ll(j,i)&
11570                        +wtube*gg_tube_sc(j,i)   &
11571                        +wbond_nucl*gradbx_nucl(j,i) &
11572                        +wvdwsb*gvdwsbx(j,i) &
11573                        +welsb*gelsbx(j,i) &
11574                        +wcorr_nucl*gradxorr_nucl(j,i)&
11575                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11576                        +wsbloc*gsblocx(j,i) &
11577                        +wcatprot* gradpepcatx(j,i)&
11578                        +wscbase*gvdwx_scbase(j,i) &
11579                        +wpepbase*gvdwx_pepbase(j,i)&
11580                        +wscpho*gvdwx_scpho(j,i)
11581 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11582
11583         enddo
11584       enddo
11585 !#define DEBUG
11586 #ifdef DEBUG
11587       write (iout,*) "gloc before adding corr"
11588       do i=1,4*nres
11589         write (iout,*) i,gloc(i,icg)
11590       enddo
11591 #endif
11592       do i=1,nres-3
11593         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11594          +wcorr5*g_corr5_loc(i) &
11595          +wcorr6*g_corr6_loc(i) &
11596          +wturn4*gel_loc_turn4(i) &
11597          +wturn3*gel_loc_turn3(i) &
11598          +wturn6*gel_loc_turn6(i) &
11599          +wel_loc*gel_loc_loc(i)
11600       enddo
11601 #ifdef DEBUG
11602       write (iout,*) "gloc after adding corr"
11603       do i=1,4*nres
11604         write (iout,*) i,gloc(i,icg)
11605       enddo
11606 #endif
11607 !#undef DEBUG
11608 #ifdef MPI
11609       if (nfgtasks.gt.1) then
11610         do j=1,3
11611           do i=0,nres
11612             gradbufc(j,i)=gradc(j,i,icg)
11613             gradbufx(j,i)=gradx(j,i,icg)
11614           enddo
11615         enddo
11616         do i=1,4*nres
11617           glocbuf(i)=gloc(i,icg)
11618         enddo
11619 !#define DEBUG
11620 #ifdef DEBUG
11621       write (iout,*) "gloc_sc before reduce"
11622       do i=1,nres
11623        do j=1,1
11624         write (iout,*) i,j,gloc_sc(j,i,icg)
11625        enddo
11626       enddo
11627 #endif
11628 !#undef DEBUG
11629         do i=1,nres
11630          do j=1,3
11631           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11632          enddo
11633         enddo
11634         time00=MPI_Wtime()
11635         call MPI_Barrier(FG_COMM,IERR)
11636         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11637         time00=MPI_Wtime()
11638         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11639           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11640         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11641           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11642         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11643           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11644         time_reduce=time_reduce+MPI_Wtime()-time00
11645         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11646           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11647         time_reduce=time_reduce+MPI_Wtime()-time00
11648 !#define DEBUG
11649 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11650 #ifdef DEBUG
11651       write (iout,*) "gloc_sc after reduce"
11652       do i=1,nres
11653        do j=1,1
11654         write (iout,*) i,j,gloc_sc(j,i,icg)
11655        enddo
11656       enddo
11657 #endif
11658 !#undef DEBUG
11659 #ifdef DEBUG
11660       write (iout,*) "gloc after reduce"
11661       do i=1,4*nres
11662         write (iout,*) i,gloc(i,icg)
11663       enddo
11664 #endif
11665       endif
11666 #endif
11667       if (gnorm_check) then
11668 !
11669 ! Compute the maximum elements of the gradient
11670 !
11671       gvdwc_max=0.0d0
11672       gvdwc_scp_max=0.0d0
11673       gelc_max=0.0d0
11674       gvdwpp_max=0.0d0
11675       gradb_max=0.0d0
11676       ghpbc_max=0.0d0
11677       gradcorr_max=0.0d0
11678       gel_loc_max=0.0d0
11679       gcorr3_turn_max=0.0d0
11680       gcorr4_turn_max=0.0d0
11681       gradcorr5_max=0.0d0
11682       gradcorr6_max=0.0d0
11683       gcorr6_turn_max=0.0d0
11684       gsccorc_max=0.0d0
11685       gscloc_max=0.0d0
11686       gvdwx_max=0.0d0
11687       gradx_scp_max=0.0d0
11688       ghpbx_max=0.0d0
11689       gradxorr_max=0.0d0
11690       gsccorx_max=0.0d0
11691       gsclocx_max=0.0d0
11692       do i=1,nct
11693         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11694         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11695         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11696         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11697          gvdwc_scp_max=gvdwc_scp_norm
11698         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11699         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11700         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11701         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11702         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11703         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11704         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11705         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11706         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11707         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11708         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11709         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11710         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11711           gcorr3_turn(1,i)))
11712         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11713           gcorr3_turn_max=gcorr3_turn_norm
11714         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11715           gcorr4_turn(1,i)))
11716         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11717           gcorr4_turn_max=gcorr4_turn_norm
11718         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11719         if (gradcorr5_norm.gt.gradcorr5_max) &
11720           gradcorr5_max=gradcorr5_norm
11721         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11722         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11723         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11724           gcorr6_turn(1,i)))
11725         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11726           gcorr6_turn_max=gcorr6_turn_norm
11727         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11728         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11729         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11730         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11731         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11732         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11733         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11734         if (gradx_scp_norm.gt.gradx_scp_max) &
11735           gradx_scp_max=gradx_scp_norm
11736         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11737         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11738         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11739         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11740         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11741         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11742         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11743         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11744       enddo
11745       if (gradout) then
11746 #ifdef AIX
11747         open(istat,file=statname,position="append")
11748 #else
11749         open(istat,file=statname,access="append")
11750 #endif
11751         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11752            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11753            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11754            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11755            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11756            gsccorx_max,gsclocx_max
11757         close(istat)
11758         if (gvdwc_max.gt.1.0d4) then
11759           write (iout,*) "gvdwc gvdwx gradb gradbx"
11760           do i=nnt,nct
11761             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11762               gradb(j,i),gradbx(j,i),j=1,3)
11763           enddo
11764           call pdbout(0.0d0,'cipiszcze',iout)
11765           call flush(iout)
11766         endif
11767       endif
11768       endif
11769 !#define DEBUG
11770 #ifdef DEBUG
11771       write (iout,*) "gradc gradx gloc"
11772       do i=1,nres
11773         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11774          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11775       enddo
11776 #endif
11777 !#undef DEBUG
11778 #ifdef TIMING
11779       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11780 #endif
11781       return
11782       end subroutine sum_gradient
11783 !-----------------------------------------------------------------------------
11784       subroutine sc_grad
11785 !      implicit real*8 (a-h,o-z)
11786       use calc_data
11787 !      include 'DIMENSIONS'
11788 !      include 'COMMON.CHAIN'
11789 !      include 'COMMON.DERIV'
11790 !      include 'COMMON.CALC'
11791 !      include 'COMMON.IOUNITS'
11792       real(kind=8), dimension(3) :: dcosom1,dcosom2
11793 !      print *,"wchodze"
11794       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11795           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11796       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11797           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11798
11799       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11800            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11801            +dCAVdOM12+ dGCLdOM12
11802 ! diagnostics only
11803 !      eom1=0.0d0
11804 !      eom2=0.0d0
11805 !      eom12=evdwij*eps1_om12
11806 ! end diagnostics
11807 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11808 !       " sigder",sigder
11809 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11810 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11811 !C      print *,sss_ele_cut,'in sc_grad'
11812       do k=1,3
11813         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11814         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11815       enddo
11816       do k=1,3
11817         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11818 !C      print *,'gg',k,gg(k)
11819        enddo
11820 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11821 !      write (iout,*) "gg",(gg(k),k=1,3)
11822       do k=1,3
11823         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11824                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11825                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11826                   *sss_ele_cut
11827
11828         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11829                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11830                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11831                   *sss_ele_cut
11832
11833 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11834 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11835 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11836 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11837       enddo
11838 !
11839 ! Calculate the components of the gradient in DC and X
11840 !
11841 !grad      do k=i,j-1
11842 !grad        do l=1,3
11843 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11844 !grad        enddo
11845 !grad      enddo
11846       do l=1,3
11847         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11848         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11849       enddo
11850       return
11851       end subroutine sc_grad
11852 #ifdef CRYST_THETA
11853 !-----------------------------------------------------------------------------
11854       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11855
11856       use comm_calcthet
11857 !      implicit real*8 (a-h,o-z)
11858 !      include 'DIMENSIONS'
11859 !      include 'COMMON.LOCAL'
11860 !      include 'COMMON.IOUNITS'
11861 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11862 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11863 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11864       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11865       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11866 !el      integer :: it
11867 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11868 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11869 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11870 !el local variables
11871
11872       delthec=thetai-thet_pred_mean
11873       delthe0=thetai-theta0i
11874 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11875       t3 = thetai-thet_pred_mean
11876       t6 = t3**2
11877       t9 = term1
11878       t12 = t3*sigcsq
11879       t14 = t12+t6*sigsqtc
11880       t16 = 1.0d0
11881       t21 = thetai-theta0i
11882       t23 = t21**2
11883       t26 = term2
11884       t27 = t21*t26
11885       t32 = termexp
11886       t40 = t32**2
11887       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11888        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11889        *(-t12*t9-ak*sig0inv*t27)
11890       return
11891       end subroutine mixder
11892 #endif
11893 !-----------------------------------------------------------------------------
11894 ! cartder.F
11895 !-----------------------------------------------------------------------------
11896       subroutine cartder
11897 !-----------------------------------------------------------------------------
11898 ! This subroutine calculates the derivatives of the consecutive virtual
11899 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11900 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11901 ! in the angles alpha and omega, describing the location of a side chain
11902 ! in its local coordinate system.
11903 !
11904 ! The derivatives are stored in the following arrays:
11905 !
11906 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11907 ! The structure is as follows:
11908 !
11909 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11910 ! 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)
11911 !         . . . . . . . . . . . .  . . . . . .
11912 ! 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)
11913 !                          .
11914 !                          .
11915 !                          .
11916 ! 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)
11917 !
11918 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11919 ! The structure is same as above.
11920 !
11921 ! DCDS - the derivatives of the side chain vectors in the local spherical
11922 ! andgles alph and omega:
11923 !
11924 ! 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)
11925 ! 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)
11926 !                          .
11927 !                          .
11928 !                          .
11929 ! 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)
11930 !
11931 ! Version of March '95, based on an early version of November '91.
11932 !
11933 !**********************************************************************
11934 !      implicit real*8 (a-h,o-z)
11935 !      include 'DIMENSIONS'
11936 !      include 'COMMON.VAR'
11937 !      include 'COMMON.CHAIN'
11938 !      include 'COMMON.DERIV'
11939 !      include 'COMMON.GEO'
11940 !      include 'COMMON.LOCAL'
11941 !      include 'COMMON.INTERACT'
11942       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11943       real(kind=8),dimension(3,3) :: dp,temp
11944 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11945       real(kind=8),dimension(3) :: xx,xx1
11946 !el local variables
11947       integer :: i,k,l,j,m,ind,ind1,jjj
11948       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11949                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11950                  sint2,xp,yp,xxp,yyp,zzp,dj
11951
11952 !      common /przechowalnia/ fromto
11953       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11954 ! get the position of the jth ijth fragment of the chain coordinate system
11955 ! in the fromto array.
11956 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11957 !
11958 !      maxdim=(nres-1)*(nres-2)/2
11959 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11960 ! calculate the derivatives of transformation matrix elements in theta
11961 !
11962
11963 !el      call flush(iout) !el
11964       do i=1,nres-2
11965         rdt(1,1,i)=-rt(1,2,i)
11966         rdt(1,2,i)= rt(1,1,i)
11967         rdt(1,3,i)= 0.0d0
11968         rdt(2,1,i)=-rt(2,2,i)
11969         rdt(2,2,i)= rt(2,1,i)
11970         rdt(2,3,i)= 0.0d0
11971         rdt(3,1,i)=-rt(3,2,i)
11972         rdt(3,2,i)= rt(3,1,i)
11973         rdt(3,3,i)= 0.0d0
11974       enddo
11975 !
11976 ! derivatives in phi
11977 !
11978       do i=2,nres-2
11979         drt(1,1,i)= 0.0d0
11980         drt(1,2,i)= 0.0d0
11981         drt(1,3,i)= 0.0d0
11982         drt(2,1,i)= rt(3,1,i)
11983         drt(2,2,i)= rt(3,2,i)
11984         drt(2,3,i)= rt(3,3,i)
11985         drt(3,1,i)=-rt(2,1,i)
11986         drt(3,2,i)=-rt(2,2,i)
11987         drt(3,3,i)=-rt(2,3,i)
11988       enddo
11989 !
11990 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11991 !
11992       do i=2,nres-2
11993         ind=indmat(i,i+1)
11994         do k=1,3
11995           do l=1,3
11996             temp(k,l)=rt(k,l,i)
11997           enddo
11998         enddo
11999         do k=1,3
12000           do l=1,3
12001             fromto(k,l,ind)=temp(k,l)
12002           enddo
12003         enddo
12004         do j=i+1,nres-2
12005           ind=indmat(i,j+1)
12006           do k=1,3
12007             do l=1,3
12008               dpkl=0.0d0
12009               do m=1,3
12010                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12011               enddo
12012               dp(k,l)=dpkl
12013               fromto(k,l,ind)=dpkl
12014             enddo
12015           enddo
12016           do k=1,3
12017             do l=1,3
12018               temp(k,l)=dp(k,l)
12019             enddo
12020           enddo
12021         enddo
12022       enddo
12023 !
12024 ! Calculate derivatives.
12025 !
12026       ind1=0
12027       do i=1,nres-2
12028       ind1=ind1+1
12029 !
12030 ! Derivatives of DC(i+1) in theta(i+2)
12031 !
12032         do j=1,3
12033           do k=1,2
12034             dpjk=0.0D0
12035             do l=1,3
12036               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12037             enddo
12038             dp(j,k)=dpjk
12039             prordt(j,k,i)=dp(j,k)
12040           enddo
12041           dp(j,3)=0.0D0
12042           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12043         enddo
12044 !
12045 ! Derivatives of SC(i+1) in theta(i+2)
12046 !
12047         xx1(1)=-0.5D0*xloc(2,i+1)
12048         xx1(2)= 0.5D0*xloc(1,i+1)
12049         do j=1,3
12050           xj=0.0D0
12051           do k=1,2
12052             xj=xj+r(j,k,i)*xx1(k)
12053           enddo
12054           xx(j)=xj
12055         enddo
12056         do j=1,3
12057           rj=0.0D0
12058           do k=1,3
12059             rj=rj+prod(j,k,i)*xx(k)
12060           enddo
12061           dxdv(j,ind1)=rj
12062         enddo
12063 !
12064 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12065 ! than the other off-diagonal derivatives.
12066 !
12067         do j=1,3
12068           dxoiij=0.0D0
12069           do k=1,3
12070             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12071           enddo
12072           dxdv(j,ind1+1)=dxoiij
12073         enddo
12074 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12075 !
12076 ! Derivatives of DC(i+1) in phi(i+2)
12077 !
12078         do j=1,3
12079           do k=1,3
12080             dpjk=0.0
12081             do l=2,3
12082               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12083             enddo
12084             dp(j,k)=dpjk
12085             prodrt(j,k,i)=dp(j,k)
12086           enddo
12087           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12088         enddo
12089 !
12090 ! Derivatives of SC(i+1) in phi(i+2)
12091 !
12092         xx(1)= 0.0D0
12093         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12094         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12095         do j=1,3
12096           rj=0.0D0
12097           do k=2,3
12098             rj=rj+prod(j,k,i)*xx(k)
12099           enddo
12100           dxdv(j+3,ind1)=-rj
12101         enddo
12102 !
12103 ! Derivatives of SC(i+1) in phi(i+3).
12104 !
12105         do j=1,3
12106           dxoiij=0.0D0
12107           do k=1,3
12108             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12109           enddo
12110           dxdv(j+3,ind1+1)=dxoiij
12111         enddo
12112 !
12113 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12114 ! theta(nres) and phi(i+3) thru phi(nres).
12115 !
12116         do j=i+1,nres-2
12117         ind1=ind1+1
12118         ind=indmat(i+1,j+1)
12119 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12120           do k=1,3
12121             do l=1,3
12122               tempkl=0.0D0
12123               do m=1,2
12124                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12125               enddo
12126               temp(k,l)=tempkl
12127             enddo
12128           enddo
12129 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12130 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12131 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12132 ! Derivatives of virtual-bond vectors in theta
12133           do k=1,3
12134             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12135           enddo
12136 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12137 ! Derivatives of SC vectors in theta
12138           do k=1,3
12139             dxoijk=0.0D0
12140             do l=1,3
12141               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12142             enddo
12143             dxdv(k,ind1+1)=dxoijk
12144           enddo
12145 !
12146 !--- Calculate the derivatives in phi
12147 !
12148           do k=1,3
12149             do l=1,3
12150               tempkl=0.0D0
12151               do m=1,3
12152                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12153               enddo
12154               temp(k,l)=tempkl
12155             enddo
12156           enddo
12157           do k=1,3
12158             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12159         enddo
12160           do k=1,3
12161             dxoijk=0.0D0
12162             do l=1,3
12163               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12164             enddo
12165             dxdv(k+3,ind1+1)=dxoijk
12166           enddo
12167         enddo
12168       enddo
12169 !
12170 ! Derivatives in alpha and omega:
12171 !
12172       do i=2,nres-1
12173 !       dsci=dsc(itype(i,1))
12174         dsci=vbld(i+nres)
12175 #ifdef OSF
12176         alphi=alph(i)
12177         omegi=omeg(i)
12178         if(alphi.ne.alphi) alphi=100.0
12179         if(omegi.ne.omegi) omegi=-100.0
12180 #else
12181       alphi=alph(i)
12182       omegi=omeg(i)
12183 #endif
12184 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12185       cosalphi=dcos(alphi)
12186       sinalphi=dsin(alphi)
12187       cosomegi=dcos(omegi)
12188       sinomegi=dsin(omegi)
12189       temp(1,1)=-dsci*sinalphi
12190       temp(2,1)= dsci*cosalphi*cosomegi
12191       temp(3,1)=-dsci*cosalphi*sinomegi
12192       temp(1,2)=0.0D0
12193       temp(2,2)=-dsci*sinalphi*sinomegi
12194       temp(3,2)=-dsci*sinalphi*cosomegi
12195       theta2=pi-0.5D0*theta(i+1)
12196       cost2=dcos(theta2)
12197       sint2=dsin(theta2)
12198       jjj=0
12199 !d      print *,((temp(l,k),l=1,3),k=1,2)
12200         do j=1,2
12201         xp=temp(1,j)
12202         yp=temp(2,j)
12203         xxp= xp*cost2+yp*sint2
12204         yyp=-xp*sint2+yp*cost2
12205         zzp=temp(3,j)
12206         xx(1)=xxp
12207         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12208         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12209         do k=1,3
12210           dj=0.0D0
12211           do l=1,3
12212             dj=dj+prod(k,l,i-1)*xx(l)
12213             enddo
12214           dxds(jjj+k,i)=dj
12215           enddo
12216         jjj=jjj+3
12217       enddo
12218       enddo
12219       return
12220       end subroutine cartder
12221 !-----------------------------------------------------------------------------
12222 ! checkder_p.F
12223 !-----------------------------------------------------------------------------
12224       subroutine check_cartgrad
12225 ! Check the gradient of Cartesian coordinates in internal coordinates.
12226 !      implicit real*8 (a-h,o-z)
12227 !      include 'DIMENSIONS'
12228 !      include 'COMMON.IOUNITS'
12229 !      include 'COMMON.VAR'
12230 !      include 'COMMON.CHAIN'
12231 !      include 'COMMON.GEO'
12232 !      include 'COMMON.LOCAL'
12233 !      include 'COMMON.DERIV'
12234       real(kind=8),dimension(6,nres) :: temp
12235       real(kind=8),dimension(3) :: xx,gg
12236       integer :: i,k,j,ii
12237       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12238 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12239 !
12240 ! Check the gradient of the virtual-bond and SC vectors in the internal
12241 ! coordinates.
12242 !
12243       aincr=1.0d-6
12244       aincr2=5.0d-7
12245       call cartder
12246       write (iout,'(a)') '**************** dx/dalpha'
12247       write (iout,'(a)')
12248       do i=2,nres-1
12249       alphi=alph(i)
12250       alph(i)=alph(i)+aincr
12251       do k=1,3
12252         temp(k,i)=dc(k,nres+i)
12253         enddo
12254       call chainbuild
12255       do k=1,3
12256         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12257         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12258         enddo
12259         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12260         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12261         write (iout,'(a)')
12262       alph(i)=alphi
12263       call chainbuild
12264       enddo
12265       write (iout,'(a)')
12266       write (iout,'(a)') '**************** dx/domega'
12267       write (iout,'(a)')
12268       do i=2,nres-1
12269       omegi=omeg(i)
12270       omeg(i)=omeg(i)+aincr
12271       do k=1,3
12272         temp(k,i)=dc(k,nres+i)
12273         enddo
12274       call chainbuild
12275       do k=1,3
12276           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12277           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12278                 (aincr*dabs(dxds(k+3,i))+aincr))
12279         enddo
12280         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12281             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12282         write (iout,'(a)')
12283       omeg(i)=omegi
12284       call chainbuild
12285       enddo
12286       write (iout,'(a)')
12287       write (iout,'(a)') '**************** dx/dtheta'
12288       write (iout,'(a)')
12289       do i=3,nres
12290       theti=theta(i)
12291         theta(i)=theta(i)+aincr
12292         do j=i-1,nres-1
12293           do k=1,3
12294             temp(k,j)=dc(k,nres+j)
12295           enddo
12296         enddo
12297         call chainbuild
12298         do j=i-1,nres-1
12299         ii = indmat(i-2,j)
12300 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12301         do k=1,3
12302           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12303           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12304                   (aincr*dabs(dxdv(k,ii))+aincr))
12305           enddo
12306           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12307               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12308           write(iout,'(a)')
12309         enddo
12310         write (iout,'(a)')
12311         theta(i)=theti
12312         call chainbuild
12313       enddo
12314       write (iout,'(a)') '***************** dx/dphi'
12315       write (iout,'(a)')
12316       do i=4,nres
12317         phi(i)=phi(i)+aincr
12318         do j=i-1,nres-1
12319           do k=1,3
12320             temp(k,j)=dc(k,nres+j)
12321           enddo
12322         enddo
12323         call chainbuild
12324         do j=i-1,nres-1
12325         ii = indmat(i-2,j)
12326 !         print *,'ii=',ii
12327         do k=1,3
12328           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12329             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12330                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12331           enddo
12332           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12333               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12334           write(iout,'(a)')
12335         enddo
12336         phi(i)=phi(i)-aincr
12337         call chainbuild
12338       enddo
12339       write (iout,'(a)') '****************** ddc/dtheta'
12340       do i=1,nres-2
12341         thet=theta(i+2)
12342         theta(i+2)=thet+aincr
12343         do j=i,nres
12344           do k=1,3
12345             temp(k,j)=dc(k,j)
12346           enddo
12347         enddo
12348         call chainbuild
12349         do j=i+1,nres-1
12350         ii = indmat(i,j)
12351 !         print *,'ii=',ii
12352         do k=1,3
12353           gg(k)=(dc(k,j)-temp(k,j))/aincr
12354           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12355                  (aincr*dabs(dcdv(k,ii))+aincr))
12356           enddo
12357           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12358                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12359         write (iout,'(a)')
12360         enddo
12361         do j=1,nres
12362           do k=1,3
12363             dc(k,j)=temp(k,j)
12364           enddo
12365         enddo
12366         theta(i+2)=thet
12367       enddo
12368       write (iout,'(a)') '******************* ddc/dphi'
12369       do i=1,nres-3
12370         phii=phi(i+3)
12371         phi(i+3)=phii+aincr
12372         do j=1,nres
12373           do k=1,3
12374             temp(k,j)=dc(k,j)
12375           enddo
12376         enddo
12377         call chainbuild
12378         do j=i+2,nres-1
12379         ii = indmat(i+1,j)
12380 !         print *,'ii=',ii
12381         do k=1,3
12382           gg(k)=(dc(k,j)-temp(k,j))/aincr
12383             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12384                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12385           enddo
12386           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12387                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12388         write (iout,'(a)')
12389         enddo
12390         do j=1,nres
12391           do k=1,3
12392             dc(k,j)=temp(k,j)
12393           enddo
12394         enddo
12395         phi(i+3)=phii
12396       enddo
12397       return
12398       end subroutine check_cartgrad
12399 !-----------------------------------------------------------------------------
12400       subroutine check_ecart
12401 ! Check the gradient of the energy in Cartesian coordinates.
12402 !     implicit real*8 (a-h,o-z)
12403 !     include 'DIMENSIONS'
12404 !     include 'COMMON.CHAIN'
12405 !     include 'COMMON.DERIV'
12406 !     include 'COMMON.IOUNITS'
12407 !     include 'COMMON.VAR'
12408 !     include 'COMMON.CONTACTS'
12409       use comm_srutu
12410 !el      integer :: icall
12411 !el      common /srutu/ icall
12412       real(kind=8),dimension(6) :: ggg
12413       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12414       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12415       real(kind=8),dimension(6,nres) :: grad_s
12416       real(kind=8),dimension(0:n_ene) :: energia,energia1
12417       integer :: uiparm(1)
12418       real(kind=8) :: urparm(1)
12419 !EL      external fdum
12420       integer :: nf,i,j,k
12421       real(kind=8) :: aincr,etot,etot1
12422       icg=1
12423       nf=0
12424       nfl=0
12425       call zerograd
12426       aincr=1.0D-5
12427       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12428       nf=0
12429       icall=0
12430       call geom_to_var(nvar,x)
12431       call etotal(energia)
12432       etot=energia(0)
12433 !el      call enerprint(energia)
12434       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12435       icall =1
12436       do i=1,nres
12437         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12438       enddo
12439       do i=1,nres
12440       do j=1,3
12441         grad_s(j,i)=gradc(j,i,icg)
12442         grad_s(j+3,i)=gradx(j,i,icg)
12443         enddo
12444       enddo
12445       call flush(iout)
12446       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12447       do i=1,nres
12448         do j=1,3
12449         xx(j)=c(j,i+nres)
12450         ddc(j)=dc(j,i)
12451         ddx(j)=dc(j,i+nres)
12452         enddo
12453       do j=1,3
12454         dc(j,i)=dc(j,i)+aincr
12455         do k=i+1,nres
12456           c(j,k)=c(j,k)+aincr
12457           c(j,k+nres)=c(j,k+nres)+aincr
12458           enddo
12459           call zerograd
12460           call etotal(energia1)
12461           etot1=energia1(0)
12462         ggg(j)=(etot1-etot)/aincr
12463         dc(j,i)=ddc(j)
12464         do k=i+1,nres
12465           c(j,k)=c(j,k)-aincr
12466           c(j,k+nres)=c(j,k+nres)-aincr
12467           enddo
12468         enddo
12469       do j=1,3
12470         c(j,i+nres)=c(j,i+nres)+aincr
12471         dc(j,i+nres)=dc(j,i+nres)+aincr
12472           call zerograd
12473           call etotal(energia1)
12474           etot1=energia1(0)
12475         ggg(j+3)=(etot1-etot)/aincr
12476         c(j,i+nres)=xx(j)
12477         dc(j,i+nres)=ddx(j)
12478         enddo
12479       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12480          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12481       enddo
12482       return
12483       end subroutine check_ecart
12484 #ifdef CARGRAD
12485 !-----------------------------------------------------------------------------
12486       subroutine check_ecartint
12487 ! Check the gradient of the energy in Cartesian coordinates.
12488       use io_base, only: intout
12489 !      implicit real*8 (a-h,o-z)
12490 !      include 'DIMENSIONS'
12491 !      include 'COMMON.CONTROL'
12492 !      include 'COMMON.CHAIN'
12493 !      include 'COMMON.DERIV'
12494 !      include 'COMMON.IOUNITS'
12495 !      include 'COMMON.VAR'
12496 !      include 'COMMON.CONTACTS'
12497 !      include 'COMMON.MD'
12498 !      include 'COMMON.LOCAL'
12499 !      include 'COMMON.SPLITELE'
12500       use comm_srutu
12501 !el      integer :: icall
12502 !el      common /srutu/ icall
12503       real(kind=8),dimension(6) :: ggg,ggg1
12504       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12505       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12506       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12507       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12508       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12509       real(kind=8),dimension(0:n_ene) :: energia,energia1
12510       integer :: uiparm(1)
12511       real(kind=8) :: urparm(1)
12512 !EL      external fdum
12513       integer :: i,j,k,nf
12514       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12515                    etot21,etot22
12516       r_cut=2.0d0
12517       rlambd=0.3d0
12518       icg=1
12519       nf=0
12520       nfl=0
12521       call intout
12522 !      call intcartderiv
12523 !      call checkintcartgrad
12524       call zerograd
12525       aincr=1.0D-4
12526       write(iout,*) 'Calling CHECK_ECARTINT.'
12527       nf=0
12528       icall=0
12529       call geom_to_var(nvar,x)
12530       write (iout,*) "split_ene ",split_ene
12531       call flush(iout)
12532       if (.not.split_ene) then
12533         call zerograd
12534         call etotal(energia)
12535         etot=energia(0)
12536         call cartgrad
12537         icall =1
12538         do i=1,nres
12539           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12540         enddo
12541         do j=1,3
12542           grad_s(j,0)=gcart(j,0)
12543         enddo
12544         do i=1,nres
12545           do j=1,3
12546             grad_s(j,i)=gcart(j,i)
12547             grad_s(j+3,i)=gxcart(j,i)
12548           enddo
12549         enddo
12550       else
12551 !- split gradient check
12552         call zerograd
12553         call etotal_long(energia)
12554 !el        call enerprint(energia)
12555         call cartgrad
12556         icall =1
12557         do i=1,nres
12558           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12559           (gxcart(j,i),j=1,3)
12560         enddo
12561         do j=1,3
12562           grad_s(j,0)=gcart(j,0)
12563         enddo
12564         do i=1,nres
12565           do j=1,3
12566             grad_s(j,i)=gcart(j,i)
12567             grad_s(j+3,i)=gxcart(j,i)
12568           enddo
12569         enddo
12570         call zerograd
12571         call etotal_short(energia)
12572         call enerprint(energia)
12573         call cartgrad
12574         icall =1
12575         do i=1,nres
12576           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12577           (gxcart(j,i),j=1,3)
12578         enddo
12579         do j=1,3
12580           grad_s1(j,0)=gcart(j,0)
12581         enddo
12582         do i=1,nres
12583           do j=1,3
12584             grad_s1(j,i)=gcart(j,i)
12585             grad_s1(j+3,i)=gxcart(j,i)
12586           enddo
12587         enddo
12588       endif
12589       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12590 !      do i=1,nres
12591       do i=nnt,nct
12592         do j=1,3
12593           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12594           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12595         ddc(j)=c(j,i)
12596         ddx(j)=c(j,i+nres)
12597           dcnorm_safe1(j)=dc_norm(j,i-1)
12598           dcnorm_safe2(j)=dc_norm(j,i)
12599           dxnorm_safe(j)=dc_norm(j,i+nres)
12600         enddo
12601       do j=1,3
12602         c(j,i)=ddc(j)+aincr
12603           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12604           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12605           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12606           dc(j,i)=c(j,i+1)-c(j,i)
12607           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12608           call int_from_cart1(.false.)
12609           if (.not.split_ene) then
12610            call zerograd
12611             call etotal(energia1)
12612             etot1=energia1(0)
12613             write (iout,*) "ij",i,j," etot1",etot1
12614           else
12615 !- split gradient
12616             call etotal_long(energia1)
12617             etot11=energia1(0)
12618             call etotal_short(energia1)
12619             etot12=energia1(0)
12620           endif
12621 !- end split gradient
12622 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12623         c(j,i)=ddc(j)-aincr
12624           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12625           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12626           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12627           dc(j,i)=c(j,i+1)-c(j,i)
12628           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12629           call int_from_cart1(.false.)
12630           if (.not.split_ene) then
12631             call zerograd
12632             call etotal(energia1)
12633             etot2=energia1(0)
12634             write (iout,*) "ij",i,j," etot2",etot2
12635           ggg(j)=(etot1-etot2)/(2*aincr)
12636           else
12637 !- split gradient
12638             call etotal_long(energia1)
12639             etot21=energia1(0)
12640           ggg(j)=(etot11-etot21)/(2*aincr)
12641             call etotal_short(energia1)
12642             etot22=energia1(0)
12643           ggg1(j)=(etot12-etot22)/(2*aincr)
12644 !- end split gradient
12645 !            write (iout,*) "etot21",etot21," etot22",etot22
12646           endif
12647 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12648         c(j,i)=ddc(j)
12649           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12650           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12651           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12652           dc(j,i)=c(j,i+1)-c(j,i)
12653           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12654           dc_norm(j,i-1)=dcnorm_safe1(j)
12655           dc_norm(j,i)=dcnorm_safe2(j)
12656           dc_norm(j,i+nres)=dxnorm_safe(j)
12657         enddo
12658       do j=1,3
12659         c(j,i+nres)=ddx(j)+aincr
12660           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12661           call int_from_cart1(.false.)
12662           if (.not.split_ene) then
12663             call zerograd
12664             call etotal(energia1)
12665             etot1=energia1(0)
12666           else
12667 !- split gradient
12668             call etotal_long(energia1)
12669             etot11=energia1(0)
12670             call etotal_short(energia1)
12671             etot12=energia1(0)
12672           endif
12673 !- end split gradient
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             etot2=energia1(0)
12681           ggg(j+3)=(etot1-etot2)/(2*aincr)
12682           else
12683 !- split gradient
12684             call etotal_long(energia1)
12685             etot21=energia1(0)
12686           ggg(j+3)=(etot11-etot21)/(2*aincr)
12687             call etotal_short(energia1)
12688             etot22=energia1(0)
12689           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12690 !- end split gradient
12691           endif
12692 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12693         c(j,i+nres)=ddx(j)
12694           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12695           dc_norm(j,i+nres)=dxnorm_safe(j)
12696           call int_from_cart1(.false.)
12697         enddo
12698       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12699          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12700         if (split_ene) then
12701           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12702          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12703          k=1,6)
12704          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12705          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12706          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12707         endif
12708       enddo
12709       return
12710       end subroutine check_ecartint
12711 #else
12712 !-----------------------------------------------------------------------------
12713       subroutine check_ecartint
12714 ! Check the gradient of the energy in Cartesian coordinates.
12715       use io_base, only: intout
12716 !      implicit real*8 (a-h,o-z)
12717 !      include 'DIMENSIONS'
12718 !      include 'COMMON.CONTROL'
12719 !      include 'COMMON.CHAIN'
12720 !      include 'COMMON.DERIV'
12721 !      include 'COMMON.IOUNITS'
12722 !      include 'COMMON.VAR'
12723 !      include 'COMMON.CONTACTS'
12724 !      include 'COMMON.MD'
12725 !      include 'COMMON.LOCAL'
12726 !      include 'COMMON.SPLITELE'
12727       use comm_srutu
12728 !el      integer :: icall
12729 !el      common /srutu/ icall
12730       real(kind=8),dimension(6) :: ggg,ggg1
12731       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12732       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12733       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12734       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12735       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12736       real(kind=8),dimension(0:n_ene) :: energia,energia1
12737       integer :: uiparm(1)
12738       real(kind=8) :: urparm(1)
12739 !EL      external fdum
12740       integer :: i,j,k,nf
12741       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12742                    etot21,etot22
12743       r_cut=2.0d0
12744       rlambd=0.3d0
12745       icg=1
12746       nf=0
12747       nfl=0
12748       call intout
12749 !      call intcartderiv
12750 !      call checkintcartgrad
12751       call zerograd
12752       aincr=2.0D-5
12753       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12754       nf=0
12755       icall=0
12756       call geom_to_var(nvar,x)
12757       if (.not.split_ene) then
12758         call etotal(energia)
12759         etot=energia(0)
12760 !el        call enerprint(energia)
12761         call cartgrad
12762         icall =1
12763         do i=1,nres
12764           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12765         enddo
12766         do j=1,3
12767           grad_s(j,0)=gcart(j,0)
12768         enddo
12769         do i=1,nres
12770           do j=1,3
12771             grad_s(j,i)=gcart(j,i)
12772 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12773
12774 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12775             grad_s(j+3,i)=gxcart(j,i)
12776           enddo
12777         enddo
12778       else
12779 !- split gradient check
12780         call zerograd
12781         call etotal_long(energia)
12782 !el        call enerprint(energia)
12783         call cartgrad
12784         icall =1
12785         do i=1,nres
12786           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12787           (gxcart(j,i),j=1,3)
12788         enddo
12789         do j=1,3
12790           grad_s(j,0)=gcart(j,0)
12791         enddo
12792         do i=1,nres
12793           do j=1,3
12794             grad_s(j,i)=gcart(j,i)
12795 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12796             grad_s(j+3,i)=gxcart(j,i)
12797           enddo
12798         enddo
12799         call zerograd
12800         call etotal_short(energia)
12801 !el        call enerprint(energia)
12802         call cartgrad
12803         icall =1
12804         do i=1,nres
12805           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12806           (gxcart(j,i),j=1,3)
12807         enddo
12808         do j=1,3
12809           grad_s1(j,0)=gcart(j,0)
12810         enddo
12811         do i=1,nres
12812           do j=1,3
12813             grad_s1(j,i)=gcart(j,i)
12814             grad_s1(j+3,i)=gxcart(j,i)
12815           enddo
12816         enddo
12817       endif
12818       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12819       do i=0,nres
12820         do j=1,3
12821         xx(j)=c(j,i+nres)
12822         ddc(j)=dc(j,i)
12823         ddx(j)=dc(j,i+nres)
12824           do k=1,3
12825             dcnorm_safe(k)=dc_norm(k,i)
12826             dxnorm_safe(k)=dc_norm(k,i+nres)
12827           enddo
12828         enddo
12829       do j=1,3
12830         dc(j,i)=ddc(j)+aincr
12831           call chainbuild_cart
12832 #ifdef MPI
12833 ! Broadcast the order to compute internal coordinates to the slaves.
12834 !          if (nfgtasks.gt.1)
12835 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12836 #endif
12837 !          call int_from_cart1(.false.)
12838           if (.not.split_ene) then
12839            call zerograd
12840             call etotal(energia1)
12841             etot1=energia1(0)
12842 !            call enerprint(energia1)
12843           else
12844 !- split gradient
12845             call etotal_long(energia1)
12846             etot11=energia1(0)
12847             call etotal_short(energia1)
12848             etot12=energia1(0)
12849 !            write (iout,*) "etot11",etot11," etot12",etot12
12850           endif
12851 !- end split gradient
12852 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12853         dc(j,i)=ddc(j)-aincr
12854           call chainbuild_cart
12855 !          call int_from_cart1(.false.)
12856           if (.not.split_ene) then
12857                   call zerograd
12858             call etotal(energia1)
12859             etot2=energia1(0)
12860           ggg(j)=(etot1-etot2)/(2*aincr)
12861           else
12862 !- split gradient
12863             call etotal_long(energia1)
12864             etot21=energia1(0)
12865           ggg(j)=(etot11-etot21)/(2*aincr)
12866             call etotal_short(energia1)
12867             etot22=energia1(0)
12868           ggg1(j)=(etot12-etot22)/(2*aincr)
12869 !- end split gradient
12870 !            write (iout,*) "etot21",etot21," etot22",etot22
12871           endif
12872 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12873         dc(j,i)=ddc(j)
12874           call chainbuild_cart
12875         enddo
12876       do j=1,3
12877         dc(j,i+nres)=ddx(j)+aincr
12878           call chainbuild_cart
12879 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12880 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12881 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12882 !          write (iout,*) "dxnormnorm",dsqrt(
12883 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12884 !          write (iout,*) "dxnormnormsafe",dsqrt(
12885 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12886 !          write (iout,*)
12887           if (.not.split_ene) then
12888             call zerograd
12889             call etotal(energia1)
12890             etot1=energia1(0)
12891           else
12892 !- split gradient
12893             call etotal_long(energia1)
12894             etot11=energia1(0)
12895             call etotal_short(energia1)
12896             etot12=energia1(0)
12897           endif
12898 !- end split gradient
12899 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12900         dc(j,i+nres)=ddx(j)-aincr
12901           call chainbuild_cart
12902 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12903 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12904 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12905 !          write (iout,*)
12906 !          write (iout,*) "dxnormnorm",dsqrt(
12907 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12908 !          write (iout,*) "dxnormnormsafe",dsqrt(
12909 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12910           if (.not.split_ene) then
12911             call zerograd
12912             call etotal(energia1)
12913             etot2=energia1(0)
12914           ggg(j+3)=(etot1-etot2)/(2*aincr)
12915           else
12916 !- split gradient
12917             call etotal_long(energia1)
12918             etot21=energia1(0)
12919           ggg(j+3)=(etot11-etot21)/(2*aincr)
12920             call etotal_short(energia1)
12921             etot22=energia1(0)
12922           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12923 !- end split gradient
12924           endif
12925 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12926         dc(j,i+nres)=ddx(j)
12927           call chainbuild_cart
12928         enddo
12929       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12930          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12931         if (split_ene) then
12932           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12933          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12934          k=1,6)
12935          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12936          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12937          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12938         endif
12939       enddo
12940       return
12941       end subroutine check_ecartint
12942 #endif
12943 !-----------------------------------------------------------------------------
12944       subroutine check_eint
12945 ! Check the gradient of energy in internal coordinates.
12946 !      implicit real*8 (a-h,o-z)
12947 !      include 'DIMENSIONS'
12948 !      include 'COMMON.CHAIN'
12949 !      include 'COMMON.DERIV'
12950 !      include 'COMMON.IOUNITS'
12951 !      include 'COMMON.VAR'
12952 !      include 'COMMON.GEO'
12953       use comm_srutu
12954 !el      integer :: icall
12955 !el      common /srutu/ icall
12956       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12957       integer :: uiparm(1)
12958       real(kind=8) :: urparm(1)
12959       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12960       character(len=6) :: key
12961 !EL      external fdum
12962       integer :: i,ii,nf
12963       real(kind=8) :: xi,aincr,etot,etot1,etot2
12964       call zerograd
12965       aincr=1.0D-7
12966       print '(a)','Calling CHECK_INT.'
12967       nf=0
12968       nfl=0
12969       icg=1
12970       call geom_to_var(nvar,x)
12971       call var_to_geom(nvar,x)
12972       call chainbuild
12973       icall=1
12974 !      print *,'ICG=',ICG
12975       call etotal(energia)
12976       etot = energia(0)
12977 !el      call enerprint(energia)
12978 !      print *,'ICG=',ICG
12979 #ifdef MPL
12980       if (MyID.ne.BossID) then
12981         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12982         nf=x(nvar+1)
12983         nfl=x(nvar+2)
12984         icg=x(nvar+3)
12985       endif
12986 #endif
12987       nf=1
12988       nfl=3
12989 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12990       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12991 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12992       icall=1
12993       do i=1,nvar
12994         xi=x(i)
12995         x(i)=xi-0.5D0*aincr
12996         call var_to_geom(nvar,x)
12997         call chainbuild
12998         call etotal(energia1)
12999         etot1=energia1(0)
13000         x(i)=xi+0.5D0*aincr
13001         call var_to_geom(nvar,x)
13002         call chainbuild
13003         call etotal(energia2)
13004         etot2=energia2(0)
13005         gg(i)=(etot2-etot1)/aincr
13006         write (iout,*) i,etot1,etot2
13007         x(i)=xi
13008       enddo
13009       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13010           '     RelDiff*100% '
13011       do i=1,nvar
13012         if (i.le.nphi) then
13013           ii=i
13014           key = ' phi'
13015         else if (i.le.nphi+ntheta) then
13016           ii=i-nphi
13017           key=' theta'
13018         else if (i.le.nphi+ntheta+nside) then
13019            ii=i-(nphi+ntheta)
13020            key=' alpha'
13021         else
13022            ii=i-(nphi+ntheta+nside)
13023            key=' omega'
13024         endif
13025         write (iout,'(i3,a,i3,3(1pd16.6))') &
13026        i,key,ii,gg(i),gana(i),&
13027        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13028       enddo
13029       return
13030       end subroutine check_eint
13031 !-----------------------------------------------------------------------------
13032 ! econstr_local.F
13033 !-----------------------------------------------------------------------------
13034       subroutine Econstr_back
13035 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13036 !      implicit real*8 (a-h,o-z)
13037 !      include 'DIMENSIONS'
13038 !      include 'COMMON.CONTROL'
13039 !      include 'COMMON.VAR'
13040 !      include 'COMMON.MD'
13041       use MD_data
13042 !#ifndef LANG0
13043 !      include 'COMMON.LANGEVIN'
13044 !#else
13045 !      include 'COMMON.LANGEVIN.lang0'
13046 !#endif
13047 !      include 'COMMON.CHAIN'
13048 !      include 'COMMON.DERIV'
13049 !      include 'COMMON.GEO'
13050 !      include 'COMMON.LOCAL'
13051 !      include 'COMMON.INTERACT'
13052 !      include 'COMMON.IOUNITS'
13053 !      include 'COMMON.NAMES'
13054 !      include 'COMMON.TIME1'
13055       integer :: i,j,ii,k
13056       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13057
13058       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13059       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13060       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13061
13062       Uconst_back=0.0d0
13063       do i=1,nres
13064         dutheta(i)=0.0d0
13065         dugamma(i)=0.0d0
13066         do j=1,3
13067           duscdiff(j,i)=0.0d0
13068           duscdiffx(j,i)=0.0d0
13069         enddo
13070       enddo
13071       do i=1,nfrag_back
13072         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13073 !
13074 ! Deviations from theta angles
13075 !
13076         utheta_i=0.0d0
13077         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13078           dtheta_i=theta(j)-thetaref(j)
13079           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13080           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13081         enddo
13082         utheta(i)=utheta_i/(ii-1)
13083 !
13084 ! Deviations from gamma angles
13085 !
13086         ugamma_i=0.0d0
13087         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13088           dgamma_i=pinorm(phi(j)-phiref(j))
13089 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13090           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13091           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13092 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13093         enddo
13094         ugamma(i)=ugamma_i/(ii-2)
13095 !
13096 ! Deviations from local SC geometry
13097 !
13098         uscdiff(i)=0.0d0
13099         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13100           dxx=xxtab(j)-xxref(j)
13101           dyy=yytab(j)-yyref(j)
13102           dzz=zztab(j)-zzref(j)
13103           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13104           do k=1,3
13105             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13106              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13107              (ii-1)
13108             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13109              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13110              (ii-1)
13111             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13112            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13113             /(ii-1)
13114           enddo
13115 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13116 !     &      xxref(j),yyref(j),zzref(j)
13117         enddo
13118         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13119 !        write (iout,*) i," uscdiff",uscdiff(i)
13120 !
13121 ! Put together deviations from local geometry
13122 !
13123         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13124           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13125 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13126 !     &   " uconst_back",uconst_back
13127         utheta(i)=dsqrt(utheta(i))
13128         ugamma(i)=dsqrt(ugamma(i))
13129         uscdiff(i)=dsqrt(uscdiff(i))
13130       enddo
13131       return
13132       end subroutine Econstr_back
13133 !-----------------------------------------------------------------------------
13134 ! energy_p_new-sep_barrier.F
13135 !-----------------------------------------------------------------------------
13136       real(kind=8) function sscale(r)
13137 !      include "COMMON.SPLITELE"
13138       real(kind=8) :: r,gamm
13139       if(r.lt.r_cut-rlamb) then
13140         sscale=1.0d0
13141       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13142         gamm=(r-(r_cut-rlamb))/rlamb
13143         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13144       else
13145         sscale=0d0
13146       endif
13147       return
13148       end function sscale
13149       real(kind=8) function sscale_grad(r)
13150 !      include "COMMON.SPLITELE"
13151       real(kind=8) :: r,gamm
13152       if(r.lt.r_cut-rlamb) then
13153         sscale_grad=0.0d0
13154       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13155         gamm=(r-(r_cut-rlamb))/rlamb
13156         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13157       else
13158         sscale_grad=0d0
13159       endif
13160       return
13161       end function sscale_grad
13162
13163 !!!!!!!!!! PBCSCALE
13164       real(kind=8) function sscale_ele(r)
13165 !      include "COMMON.SPLITELE"
13166       real(kind=8) :: r,gamm
13167       if(r.lt.r_cut_ele-rlamb_ele) then
13168         sscale_ele=1.0d0
13169       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13170         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13171         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13172       else
13173         sscale_ele=0d0
13174       endif
13175       return
13176       end function sscale_ele
13177
13178       real(kind=8)  function sscagrad_ele(r)
13179       real(kind=8) :: r,gamm
13180 !      include "COMMON.SPLITELE"
13181       if(r.lt.r_cut_ele-rlamb_ele) then
13182         sscagrad_ele=0.0d0
13183       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13184         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13185         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13186       else
13187         sscagrad_ele=0.0d0
13188       endif
13189       return
13190       end function sscagrad_ele
13191       real(kind=8) function sscalelip(r)
13192       real(kind=8) r,gamm
13193         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13194       return
13195       end function sscalelip
13196 !C-----------------------------------------------------------------------
13197       real(kind=8) function sscagradlip(r)
13198       real(kind=8) r,gamm
13199         sscagradlip=r*(6.0d0*r-6.0d0)
13200       return
13201       end function sscagradlip
13202
13203 !!!!!!!!!!!!!!!
13204 !-----------------------------------------------------------------------------
13205       subroutine elj_long(evdw)
13206 !
13207 ! This subroutine calculates the interaction energy of nonbonded side chains
13208 ! assuming the LJ potential of interaction.
13209 !
13210 !      implicit real*8 (a-h,o-z)
13211 !      include 'DIMENSIONS'
13212 !      include 'COMMON.GEO'
13213 !      include 'COMMON.VAR'
13214 !      include 'COMMON.LOCAL'
13215 !      include 'COMMON.CHAIN'
13216 !      include 'COMMON.DERIV'
13217 !      include 'COMMON.INTERACT'
13218 !      include 'COMMON.TORSION'
13219 !      include 'COMMON.SBRIDGE'
13220 !      include 'COMMON.NAMES'
13221 !      include 'COMMON.IOUNITS'
13222 !      include 'COMMON.CONTACTS'
13223       real(kind=8),parameter :: accur=1.0d-10
13224       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13225 !el local variables
13226       integer :: i,iint,j,k,itypi,itypi1,itypj
13227       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13228       real(kind=8) :: e1,e2,evdwij,evdw
13229 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13230       evdw=0.0D0
13231       do i=iatsc_s,iatsc_e
13232         itypi=itype(i,1)
13233         if (itypi.eq.ntyp1) cycle
13234         itypi1=itype(i+1,1)
13235         xi=c(1,nres+i)
13236         yi=c(2,nres+i)
13237         zi=c(3,nres+i)
13238 !
13239 ! Calculate SC interaction energy.
13240 !
13241         do iint=1,nint_gr(i)
13242 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13243 !d   &                  'iend=',iend(i,iint)
13244           do j=istart(i,iint),iend(i,iint)
13245             itypj=itype(j,1)
13246             if (itypj.eq.ntyp1) cycle
13247             xj=c(1,nres+j)-xi
13248             yj=c(2,nres+j)-yi
13249             zj=c(3,nres+j)-zi
13250             rij=xj*xj+yj*yj+zj*zj
13251             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13252             if (sss.lt.1.0d0) then
13253               rrij=1.0D0/rij
13254               eps0ij=eps(itypi,itypj)
13255               fac=rrij**expon2
13256               e1=fac*fac*aa_aq(itypi,itypj)
13257               e2=fac*bb_aq(itypi,itypj)
13258               evdwij=e1+e2
13259               evdw=evdw+(1.0d0-sss)*evdwij
13260 !
13261 ! Calculate the components of the gradient in DC and X
13262 !
13263               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13264               gg(1)=xj*fac
13265               gg(2)=yj*fac
13266               gg(3)=zj*fac
13267               do k=1,3
13268                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13269                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13270                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13271                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13272               enddo
13273             endif
13274           enddo      ! j
13275         enddo        ! iint
13276       enddo          ! i
13277       do i=1,nct
13278         do j=1,3
13279           gvdwc(j,i)=expon*gvdwc(j,i)
13280           gvdwx(j,i)=expon*gvdwx(j,i)
13281         enddo
13282       enddo
13283 !******************************************************************************
13284 !
13285 !                              N O T E !!!
13286 !
13287 ! To save time, the factor of EXPON has been extracted from ALL components
13288 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13289 ! use!
13290 !
13291 !******************************************************************************
13292       return
13293       end subroutine elj_long
13294 !-----------------------------------------------------------------------------
13295       subroutine elj_short(evdw)
13296 !
13297 ! This subroutine calculates the interaction energy of nonbonded side chains
13298 ! assuming the LJ potential of interaction.
13299 !
13300 !      implicit real*8 (a-h,o-z)
13301 !      include 'DIMENSIONS'
13302 !      include 'COMMON.GEO'
13303 !      include 'COMMON.VAR'
13304 !      include 'COMMON.LOCAL'
13305 !      include 'COMMON.CHAIN'
13306 !      include 'COMMON.DERIV'
13307 !      include 'COMMON.INTERACT'
13308 !      include 'COMMON.TORSION'
13309 !      include 'COMMON.SBRIDGE'
13310 !      include 'COMMON.NAMES'
13311 !      include 'COMMON.IOUNITS'
13312 !      include 'COMMON.CONTACTS'
13313       real(kind=8),parameter :: accur=1.0d-10
13314       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13315 !el local variables
13316       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13317       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13318       real(kind=8) :: e1,e2,evdwij,evdw
13319 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13320       evdw=0.0D0
13321       do i=iatsc_s,iatsc_e
13322         itypi=itype(i,1)
13323         if (itypi.eq.ntyp1) cycle
13324         itypi1=itype(i+1,1)
13325         xi=c(1,nres+i)
13326         yi=c(2,nres+i)
13327         zi=c(3,nres+i)
13328 ! Change 12/1/95
13329         num_conti=0
13330 !
13331 ! Calculate SC interaction energy.
13332 !
13333         do iint=1,nint_gr(i)
13334 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13335 !d   &                  'iend=',iend(i,iint)
13336           do j=istart(i,iint),iend(i,iint)
13337             itypj=itype(j,1)
13338             if (itypj.eq.ntyp1) cycle
13339             xj=c(1,nres+j)-xi
13340             yj=c(2,nres+j)-yi
13341             zj=c(3,nres+j)-zi
13342 ! Change 12/1/95 to calculate four-body interactions
13343             rij=xj*xj+yj*yj+zj*zj
13344             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13345             if (sss.gt.0.0d0) then
13346               rrij=1.0D0/rij
13347               eps0ij=eps(itypi,itypj)
13348               fac=rrij**expon2
13349               e1=fac*fac*aa_aq(itypi,itypj)
13350               e2=fac*bb_aq(itypi,itypj)
13351               evdwij=e1+e2
13352               evdw=evdw+sss*evdwij
13353 !
13354 ! Calculate the components of the gradient in DC and X
13355 !
13356               fac=-rrij*(e1+evdwij)*sss
13357               gg(1)=xj*fac
13358               gg(2)=yj*fac
13359               gg(3)=zj*fac
13360               do k=1,3
13361                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13362                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13363                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13364                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13365               enddo
13366             endif
13367           enddo      ! j
13368         enddo        ! iint
13369       enddo          ! i
13370       do i=1,nct
13371         do j=1,3
13372           gvdwc(j,i)=expon*gvdwc(j,i)
13373           gvdwx(j,i)=expon*gvdwx(j,i)
13374         enddo
13375       enddo
13376 !******************************************************************************
13377 !
13378 !                              N O T E !!!
13379 !
13380 ! To save time, the factor of EXPON has been extracted from ALL components
13381 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13382 ! use!
13383 !
13384 !******************************************************************************
13385       return
13386       end subroutine elj_short
13387 !-----------------------------------------------------------------------------
13388       subroutine eljk_long(evdw)
13389 !
13390 ! This subroutine calculates the interaction energy of nonbonded side chains
13391 ! assuming the LJK potential of interaction.
13392 !
13393 !      implicit real*8 (a-h,o-z)
13394 !      include 'DIMENSIONS'
13395 !      include 'COMMON.GEO'
13396 !      include 'COMMON.VAR'
13397 !      include 'COMMON.LOCAL'
13398 !      include 'COMMON.CHAIN'
13399 !      include 'COMMON.DERIV'
13400 !      include 'COMMON.INTERACT'
13401 !      include 'COMMON.IOUNITS'
13402 !      include 'COMMON.NAMES'
13403       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13404       logical :: scheck
13405 !el local variables
13406       integer :: i,iint,j,k,itypi,itypi1,itypj
13407       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13408                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13409 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13410       evdw=0.0D0
13411       do i=iatsc_s,iatsc_e
13412         itypi=itype(i,1)
13413         if (itypi.eq.ntyp1) cycle
13414         itypi1=itype(i+1,1)
13415         xi=c(1,nres+i)
13416         yi=c(2,nres+i)
13417         zi=c(3,nres+i)
13418 !
13419 ! Calculate SC interaction energy.
13420 !
13421         do iint=1,nint_gr(i)
13422           do j=istart(i,iint),iend(i,iint)
13423             itypj=itype(j,1)
13424             if (itypj.eq.ntyp1) cycle
13425             xj=c(1,nres+j)-xi
13426             yj=c(2,nres+j)-yi
13427             zj=c(3,nres+j)-zi
13428             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13429             fac_augm=rrij**expon
13430             e_augm=augm(itypi,itypj)*fac_augm
13431             r_inv_ij=dsqrt(rrij)
13432             rij=1.0D0/r_inv_ij
13433             sss=sscale(rij/sigma(itypi,itypj))
13434             if (sss.lt.1.0d0) then
13435               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13436               fac=r_shift_inv**expon
13437               e1=fac*fac*aa_aq(itypi,itypj)
13438               e2=fac*bb_aq(itypi,itypj)
13439               evdwij=e_augm+e1+e2
13440 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13441 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13442 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13443 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13444 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13445 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13446 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13447               evdw=evdw+(1.0d0-sss)*evdwij
13448 !
13449 ! Calculate the components of the gradient in DC and X
13450 !
13451               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13452               fac=fac*(1.0d0-sss)
13453               gg(1)=xj*fac
13454               gg(2)=yj*fac
13455               gg(3)=zj*fac
13456               do k=1,3
13457                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13458                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13459                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13460                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13461               enddo
13462             endif
13463           enddo      ! j
13464         enddo        ! iint
13465       enddo          ! i
13466       do i=1,nct
13467         do j=1,3
13468           gvdwc(j,i)=expon*gvdwc(j,i)
13469           gvdwx(j,i)=expon*gvdwx(j,i)
13470         enddo
13471       enddo
13472       return
13473       end subroutine eljk_long
13474 !-----------------------------------------------------------------------------
13475       subroutine eljk_short(evdw)
13476 !
13477 ! This subroutine calculates the interaction energy of nonbonded side chains
13478 ! assuming the LJK potential of interaction.
13479 !
13480 !      implicit real*8 (a-h,o-z)
13481 !      include 'DIMENSIONS'
13482 !      include 'COMMON.GEO'
13483 !      include 'COMMON.VAR'
13484 !      include 'COMMON.LOCAL'
13485 !      include 'COMMON.CHAIN'
13486 !      include 'COMMON.DERIV'
13487 !      include 'COMMON.INTERACT'
13488 !      include 'COMMON.IOUNITS'
13489 !      include 'COMMON.NAMES'
13490       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13491       logical :: scheck
13492 !el local variables
13493       integer :: i,iint,j,k,itypi,itypi1,itypj
13494       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13495                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13496 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13497       evdw=0.0D0
13498       do i=iatsc_s,iatsc_e
13499         itypi=itype(i,1)
13500         if (itypi.eq.ntyp1) cycle
13501         itypi1=itype(i+1,1)
13502         xi=c(1,nres+i)
13503         yi=c(2,nres+i)
13504         zi=c(3,nres+i)
13505 !
13506 ! Calculate SC interaction energy.
13507 !
13508         do iint=1,nint_gr(i)
13509           do j=istart(i,iint),iend(i,iint)
13510             itypj=itype(j,1)
13511             if (itypj.eq.ntyp1) cycle
13512             xj=c(1,nres+j)-xi
13513             yj=c(2,nres+j)-yi
13514             zj=c(3,nres+j)-zi
13515             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13516             fac_augm=rrij**expon
13517             e_augm=augm(itypi,itypj)*fac_augm
13518             r_inv_ij=dsqrt(rrij)
13519             rij=1.0D0/r_inv_ij
13520             sss=sscale(rij/sigma(itypi,itypj))
13521             if (sss.gt.0.0d0) then
13522               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13523               fac=r_shift_inv**expon
13524               e1=fac*fac*aa_aq(itypi,itypj)
13525               e2=fac*bb_aq(itypi,itypj)
13526               evdwij=e_augm+e1+e2
13527 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13528 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13529 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13530 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13531 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13532 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13533 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13534               evdw=evdw+sss*evdwij
13535 !
13536 ! Calculate the components of the gradient in DC and X
13537 !
13538               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13539               fac=fac*sss
13540               gg(1)=xj*fac
13541               gg(2)=yj*fac
13542               gg(3)=zj*fac
13543               do k=1,3
13544                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13545                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13546                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13547                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13548               enddo
13549             endif
13550           enddo      ! j
13551         enddo        ! iint
13552       enddo          ! i
13553       do i=1,nct
13554         do j=1,3
13555           gvdwc(j,i)=expon*gvdwc(j,i)
13556           gvdwx(j,i)=expon*gvdwx(j,i)
13557         enddo
13558       enddo
13559       return
13560       end subroutine eljk_short
13561 !-----------------------------------------------------------------------------
13562       subroutine ebp_long(evdw)
13563 !
13564 ! This subroutine calculates the interaction energy of nonbonded side chains
13565 ! assuming the Berne-Pechukas potential of interaction.
13566 !
13567       use calc_data
13568 !      implicit real*8 (a-h,o-z)
13569 !      include 'DIMENSIONS'
13570 !      include 'COMMON.GEO'
13571 !      include 'COMMON.VAR'
13572 !      include 'COMMON.LOCAL'
13573 !      include 'COMMON.CHAIN'
13574 !      include 'COMMON.DERIV'
13575 !      include 'COMMON.NAMES'
13576 !      include 'COMMON.INTERACT'
13577 !      include 'COMMON.IOUNITS'
13578 !      include 'COMMON.CALC'
13579       use comm_srutu
13580 !el      integer :: icall
13581 !el      common /srutu/ icall
13582 !     double precision rrsave(maxdim)
13583       logical :: lprn
13584 !el local variables
13585       integer :: iint,itypi,itypi1,itypj
13586       real(kind=8) :: rrij,xi,yi,zi,fac
13587       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13588       evdw=0.0D0
13589 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13590       evdw=0.0D0
13591 !     if (icall.eq.0) then
13592 !       lprn=.true.
13593 !     else
13594         lprn=.false.
13595 !     endif
13596 !el      ind=0
13597       do i=iatsc_s,iatsc_e
13598         itypi=itype(i,1)
13599         if (itypi.eq.ntyp1) cycle
13600         itypi1=itype(i+1,1)
13601         xi=c(1,nres+i)
13602         yi=c(2,nres+i)
13603         zi=c(3,nres+i)
13604         dxi=dc_norm(1,nres+i)
13605         dyi=dc_norm(2,nres+i)
13606         dzi=dc_norm(3,nres+i)
13607 !        dsci_inv=dsc_inv(itypi)
13608         dsci_inv=vbld_inv(i+nres)
13609 !
13610 ! Calculate SC interaction energy.
13611 !
13612         do iint=1,nint_gr(i)
13613           do j=istart(i,iint),iend(i,iint)
13614 !el            ind=ind+1
13615             itypj=itype(j,1)
13616             if (itypj.eq.ntyp1) cycle
13617 !            dscj_inv=dsc_inv(itypj)
13618             dscj_inv=vbld_inv(j+nres)
13619             chi1=chi(itypi,itypj)
13620             chi2=chi(itypj,itypi)
13621             chi12=chi1*chi2
13622             chip1=chip(itypi)
13623             chip2=chip(itypj)
13624             chip12=chip1*chip2
13625             alf1=alp(itypi)
13626             alf2=alp(itypj)
13627             alf12=0.5D0*(alf1+alf2)
13628             xj=c(1,nres+j)-xi
13629             yj=c(2,nres+j)-yi
13630             zj=c(3,nres+j)-zi
13631             dxj=dc_norm(1,nres+j)
13632             dyj=dc_norm(2,nres+j)
13633             dzj=dc_norm(3,nres+j)
13634             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13635             rij=dsqrt(rrij)
13636             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13637
13638             if (sss.lt.1.0d0) then
13639
13640 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13641               call sc_angular
13642 ! Calculate whole angle-dependent part of epsilon and contributions
13643 ! to its derivatives
13644               fac=(rrij*sigsq)**expon2
13645               e1=fac*fac*aa_aq(itypi,itypj)
13646               e2=fac*bb_aq(itypi,itypj)
13647               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13648               eps2der=evdwij*eps3rt
13649               eps3der=evdwij*eps2rt
13650               evdwij=evdwij*eps2rt*eps3rt
13651               evdw=evdw+evdwij*(1.0d0-sss)
13652               if (lprn) then
13653               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13654               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13655 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13656 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13657 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13658 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13659 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13660 !d     &          evdwij
13661               endif
13662 ! Calculate gradient components.
13663               e1=e1*eps1*eps2rt**2*eps3rt**2
13664               fac=-expon*(e1+evdwij)
13665               sigder=fac/sigsq
13666               fac=rrij*fac
13667 ! Calculate radial part of the gradient
13668               gg(1)=xj*fac
13669               gg(2)=yj*fac
13670               gg(3)=zj*fac
13671 ! Calculate the angular part of the gradient and sum add the contributions
13672 ! to the appropriate components of the Cartesian gradient.
13673               call sc_grad_scale(1.0d0-sss)
13674             endif
13675           enddo      ! j
13676         enddo        ! iint
13677       enddo          ! i
13678 !     stop
13679       return
13680       end subroutine ebp_long
13681 !-----------------------------------------------------------------------------
13682       subroutine ebp_short(evdw)
13683 !
13684 ! This subroutine calculates the interaction energy of nonbonded side chains
13685 ! assuming the Berne-Pechukas potential of interaction.
13686 !
13687       use calc_data
13688 !      implicit real*8 (a-h,o-z)
13689 !      include 'DIMENSIONS'
13690 !      include 'COMMON.GEO'
13691 !      include 'COMMON.VAR'
13692 !      include 'COMMON.LOCAL'
13693 !      include 'COMMON.CHAIN'
13694 !      include 'COMMON.DERIV'
13695 !      include 'COMMON.NAMES'
13696 !      include 'COMMON.INTERACT'
13697 !      include 'COMMON.IOUNITS'
13698 !      include 'COMMON.CALC'
13699       use comm_srutu
13700 !el      integer :: icall
13701 !el      common /srutu/ icall
13702 !     double precision rrsave(maxdim)
13703       logical :: lprn
13704 !el local variables
13705       integer :: iint,itypi,itypi1,itypj
13706       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13707       real(kind=8) :: sss,e1,e2,evdw
13708       evdw=0.0D0
13709 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13710       evdw=0.0D0
13711 !     if (icall.eq.0) then
13712 !       lprn=.true.
13713 !     else
13714         lprn=.false.
13715 !     endif
13716 !el      ind=0
13717       do i=iatsc_s,iatsc_e
13718         itypi=itype(i,1)
13719         if (itypi.eq.ntyp1) cycle
13720         itypi1=itype(i+1,1)
13721         xi=c(1,nres+i)
13722         yi=c(2,nres+i)
13723         zi=c(3,nres+i)
13724         dxi=dc_norm(1,nres+i)
13725         dyi=dc_norm(2,nres+i)
13726         dzi=dc_norm(3,nres+i)
13727 !        dsci_inv=dsc_inv(itypi)
13728         dsci_inv=vbld_inv(i+nres)
13729 !
13730 ! Calculate SC interaction energy.
13731 !
13732         do iint=1,nint_gr(i)
13733           do j=istart(i,iint),iend(i,iint)
13734 !el            ind=ind+1
13735             itypj=itype(j,1)
13736             if (itypj.eq.ntyp1) cycle
13737 !            dscj_inv=dsc_inv(itypj)
13738             dscj_inv=vbld_inv(j+nres)
13739             chi1=chi(itypi,itypj)
13740             chi2=chi(itypj,itypi)
13741             chi12=chi1*chi2
13742             chip1=chip(itypi)
13743             chip2=chip(itypj)
13744             chip12=chip1*chip2
13745             alf1=alp(itypi)
13746             alf2=alp(itypj)
13747             alf12=0.5D0*(alf1+alf2)
13748             xj=c(1,nres+j)-xi
13749             yj=c(2,nres+j)-yi
13750             zj=c(3,nres+j)-zi
13751             dxj=dc_norm(1,nres+j)
13752             dyj=dc_norm(2,nres+j)
13753             dzj=dc_norm(3,nres+j)
13754             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13755             rij=dsqrt(rrij)
13756             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13757
13758             if (sss.gt.0.0d0) then
13759
13760 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13761               call sc_angular
13762 ! Calculate whole angle-dependent part of epsilon and contributions
13763 ! to its derivatives
13764               fac=(rrij*sigsq)**expon2
13765               e1=fac*fac*aa_aq(itypi,itypj)
13766               e2=fac*bb_aq(itypi,itypj)
13767               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13768               eps2der=evdwij*eps3rt
13769               eps3der=evdwij*eps2rt
13770               evdwij=evdwij*eps2rt*eps3rt
13771               evdw=evdw+evdwij*sss
13772               if (lprn) then
13773               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13774               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13775 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13776 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13777 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13778 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13779 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13780 !d     &          evdwij
13781               endif
13782 ! Calculate gradient components.
13783               e1=e1*eps1*eps2rt**2*eps3rt**2
13784               fac=-expon*(e1+evdwij)
13785               sigder=fac/sigsq
13786               fac=rrij*fac
13787 ! Calculate radial part of the gradient
13788               gg(1)=xj*fac
13789               gg(2)=yj*fac
13790               gg(3)=zj*fac
13791 ! Calculate the angular part of the gradient and sum add the contributions
13792 ! to the appropriate components of the Cartesian gradient.
13793               call sc_grad_scale(sss)
13794             endif
13795           enddo      ! j
13796         enddo        ! iint
13797       enddo          ! i
13798 !     stop
13799       return
13800       end subroutine ebp_short
13801 !-----------------------------------------------------------------------------
13802       subroutine egb_long(evdw)
13803 !
13804 ! This subroutine calculates the interaction energy of nonbonded side chains
13805 ! assuming the Gay-Berne potential of interaction.
13806 !
13807       use calc_data
13808 !      implicit real*8 (a-h,o-z)
13809 !      include 'DIMENSIONS'
13810 !      include 'COMMON.GEO'
13811 !      include 'COMMON.VAR'
13812 !      include 'COMMON.LOCAL'
13813 !      include 'COMMON.CHAIN'
13814 !      include 'COMMON.DERIV'
13815 !      include 'COMMON.NAMES'
13816 !      include 'COMMON.INTERACT'
13817 !      include 'COMMON.IOUNITS'
13818 !      include 'COMMON.CALC'
13819 !      include 'COMMON.CONTROL'
13820       logical :: lprn
13821 !el local variables
13822       integer :: iint,itypi,itypi1,itypj,subchap
13823       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13824       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13825       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13826                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13827                     ssgradlipi,ssgradlipj
13828
13829
13830       evdw=0.0D0
13831 !cccc      energy_dec=.false.
13832 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13833       evdw=0.0D0
13834       lprn=.false.
13835 !     if (icall.eq.0) lprn=.false.
13836 !el      ind=0
13837       do i=iatsc_s,iatsc_e
13838         itypi=itype(i,1)
13839         if (itypi.eq.ntyp1) cycle
13840         itypi1=itype(i+1,1)
13841         xi=c(1,nres+i)
13842         yi=c(2,nres+i)
13843         zi=c(3,nres+i)
13844           xi=mod(xi,boxxsize)
13845           if (xi.lt.0) xi=xi+boxxsize
13846           yi=mod(yi,boxysize)
13847           if (yi.lt.0) yi=yi+boxysize
13848           zi=mod(zi,boxzsize)
13849           if (zi.lt.0) zi=zi+boxzsize
13850        if ((zi.gt.bordlipbot)    &
13851         .and.(zi.lt.bordliptop)) then
13852 !C the energy transfer exist
13853         if (zi.lt.buflipbot) then
13854 !C what fraction I am in
13855          fracinbuf=1.0d0-    &
13856              ((zi-bordlipbot)/lipbufthick)
13857 !C lipbufthick is thickenes of lipid buffore
13858          sslipi=sscalelip(fracinbuf)
13859          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13860         elseif (zi.gt.bufliptop) then
13861          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13862          sslipi=sscalelip(fracinbuf)
13863          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13864         else
13865          sslipi=1.0d0
13866          ssgradlipi=0.0
13867         endif
13868        else
13869          sslipi=0.0d0
13870          ssgradlipi=0.0
13871        endif
13872
13873         dxi=dc_norm(1,nres+i)
13874         dyi=dc_norm(2,nres+i)
13875         dzi=dc_norm(3,nres+i)
13876 !        dsci_inv=dsc_inv(itypi)
13877         dsci_inv=vbld_inv(i+nres)
13878 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13879 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13880 !
13881 ! Calculate SC interaction energy.
13882 !
13883         do iint=1,nint_gr(i)
13884           do j=istart(i,iint),iend(i,iint)
13885             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13886 !              call dyn_ssbond_ene(i,j,evdwij)
13887 !              evdw=evdw+evdwij
13888 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13889 !                              'evdw',i,j,evdwij,' ss'
13890 !              if (energy_dec) write (iout,*) &
13891 !                              'evdw',i,j,evdwij,' ss'
13892 !             do k=j+1,iend(i,iint)
13893 !C search over all next residues
13894 !              if (dyn_ss_mask(k)) then
13895 !C check if they are cysteins
13896 !C              write(iout,*) 'k=',k
13897
13898 !c              write(iout,*) "PRZED TRI", evdwij
13899 !               evdwij_przed_tri=evdwij
13900 !              call triple_ssbond_ene(i,j,k,evdwij)
13901 !c               if(evdwij_przed_tri.ne.evdwij) then
13902 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13903 !c               endif
13904
13905 !c              write(iout,*) "PO TRI", evdwij
13906 !C call the energy function that removes the artifical triple disulfide
13907 !C bond the soubroutine is located in ssMD.F
13908 !              evdw=evdw+evdwij
13909               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13910                             'evdw',i,j,evdwij,'tss'
13911 !              endif!dyn_ss_mask(k)
13912 !             enddo! k
13913
13914             ELSE
13915 !el            ind=ind+1
13916             itypj=itype(j,1)
13917             if (itypj.eq.ntyp1) cycle
13918 !            dscj_inv=dsc_inv(itypj)
13919             dscj_inv=vbld_inv(j+nres)
13920 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13921 !     &       1.0d0/vbld(j+nres)
13922 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13923             sig0ij=sigma(itypi,itypj)
13924             chi1=chi(itypi,itypj)
13925             chi2=chi(itypj,itypi)
13926             chi12=chi1*chi2
13927             chip1=chip(itypi)
13928             chip2=chip(itypj)
13929             chip12=chip1*chip2
13930             alf1=alp(itypi)
13931             alf2=alp(itypj)
13932             alf12=0.5D0*(alf1+alf2)
13933             xj=c(1,nres+j)
13934             yj=c(2,nres+j)
13935             zj=c(3,nres+j)
13936 ! Searching for nearest neighbour
13937           xj=mod(xj,boxxsize)
13938           if (xj.lt.0) xj=xj+boxxsize
13939           yj=mod(yj,boxysize)
13940           if (yj.lt.0) yj=yj+boxysize
13941           zj=mod(zj,boxzsize)
13942           if (zj.lt.0) zj=zj+boxzsize
13943        if ((zj.gt.bordlipbot)   &
13944       .and.(zj.lt.bordliptop)) then
13945 !C the energy transfer exist
13946         if (zj.lt.buflipbot) then
13947 !C what fraction I am in
13948          fracinbuf=1.0d0-  &
13949              ((zj-bordlipbot)/lipbufthick)
13950 !C lipbufthick is thickenes of lipid buffore
13951          sslipj=sscalelip(fracinbuf)
13952          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13953         elseif (zj.gt.bufliptop) then
13954          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13955          sslipj=sscalelip(fracinbuf)
13956          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13957         else
13958          sslipj=1.0d0
13959          ssgradlipj=0.0
13960         endif
13961        else
13962          sslipj=0.0d0
13963          ssgradlipj=0.0
13964        endif
13965       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13966        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13967       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13968        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13969
13970           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13971           xj_safe=xj
13972           yj_safe=yj
13973           zj_safe=zj
13974           subchap=0
13975           do xshift=-1,1
13976           do yshift=-1,1
13977           do zshift=-1,1
13978           xj=xj_safe+xshift*boxxsize
13979           yj=yj_safe+yshift*boxysize
13980           zj=zj_safe+zshift*boxzsize
13981           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13982           if(dist_temp.lt.dist_init) then
13983             dist_init=dist_temp
13984             xj_temp=xj
13985             yj_temp=yj
13986             zj_temp=zj
13987             subchap=1
13988           endif
13989           enddo
13990           enddo
13991           enddo
13992           if (subchap.eq.1) then
13993           xj=xj_temp-xi
13994           yj=yj_temp-yi
13995           zj=zj_temp-zi
13996           else
13997           xj=xj_safe-xi
13998           yj=yj_safe-yi
13999           zj=zj_safe-zi
14000           endif
14001
14002             dxj=dc_norm(1,nres+j)
14003             dyj=dc_norm(2,nres+j)
14004             dzj=dc_norm(3,nres+j)
14005             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14006             rij=dsqrt(rrij)
14007             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14008             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
14009             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
14010             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14011             if (sss_ele_cut.le.0.0) cycle
14012             if (sss.lt.1.0d0) then
14013
14014 ! Calculate angle-dependent terms of energy and contributions to their
14015 ! derivatives.
14016               call sc_angular
14017               sigsq=1.0D0/sigsq
14018               sig=sig0ij*dsqrt(sigsq)
14019               rij_shift=1.0D0/rij-sig+sig0ij
14020 ! for diagnostics; uncomment
14021 !              rij_shift=1.2*sig0ij
14022 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14023               if (rij_shift.le.0.0D0) then
14024                 evdw=1.0D20
14025 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14026 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14027 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14028                 return
14029               endif
14030               sigder=-sig*sigsq
14031 !---------------------------------------------------------------
14032               rij_shift=1.0D0/rij_shift
14033               fac=rij_shift**expon
14034               e1=fac*fac*aa
14035               e2=fac*bb
14036               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14037               eps2der=evdwij*eps3rt
14038               eps3der=evdwij*eps2rt
14039 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14040 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14041               evdwij=evdwij*eps2rt*eps3rt
14042               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14043               if (lprn) then
14044               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14045               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14046               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14047                 restyp(itypi,1),i,restyp(itypj,1),j,&
14048                 epsi,sigm,chi1,chi2,chip1,chip2,&
14049                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14050                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14051                 evdwij
14052               endif
14053
14054               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14055                               'evdw',i,j,evdwij
14056 !              if (energy_dec) write (iout,*) &
14057 !                              'evdw',i,j,evdwij,"egb_long"
14058
14059 ! Calculate gradient components.
14060               e1=e1*eps1*eps2rt**2*eps3rt**2
14061               fac=-expon*(e1+evdwij)*rij_shift
14062               sigder=fac*sigder
14063               fac=rij*fac
14064               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14065             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
14066             /sigmaii(itypi,itypj))
14067 !              fac=0.0d0
14068 ! Calculate the radial part of the gradient
14069               gg(1)=xj*fac
14070               gg(2)=yj*fac
14071               gg(3)=zj*fac
14072 ! Calculate angular part of the gradient.
14073               call sc_grad_scale(1.0d0-sss)
14074             ENDIF    !mask_dyn_ss
14075             endif
14076           enddo      ! j
14077         enddo        ! iint
14078       enddo          ! i
14079 !      write (iout,*) "Number of loop steps in EGB:",ind
14080 !ccc      energy_dec=.false.
14081       return
14082       end subroutine egb_long
14083 !-----------------------------------------------------------------------------
14084       subroutine egb_short(evdw)
14085 !
14086 ! This subroutine calculates the interaction energy of nonbonded side chains
14087 ! assuming the Gay-Berne potential of interaction.
14088 !
14089       use calc_data
14090 !      implicit real*8 (a-h,o-z)
14091 !      include 'DIMENSIONS'
14092 !      include 'COMMON.GEO'
14093 !      include 'COMMON.VAR'
14094 !      include 'COMMON.LOCAL'
14095 !      include 'COMMON.CHAIN'
14096 !      include 'COMMON.DERIV'
14097 !      include 'COMMON.NAMES'
14098 !      include 'COMMON.INTERACT'
14099 !      include 'COMMON.IOUNITS'
14100 !      include 'COMMON.CALC'
14101 !      include 'COMMON.CONTROL'
14102       logical :: lprn
14103 !el local variables
14104       integer :: iint,itypi,itypi1,itypj,subchap
14105       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14106       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14107       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14108                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14109                     ssgradlipi,ssgradlipj
14110       evdw=0.0D0
14111 !cccc      energy_dec=.false.
14112 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14113       evdw=0.0D0
14114       lprn=.false.
14115 !     if (icall.eq.0) lprn=.false.
14116 !el      ind=0
14117       do i=iatsc_s,iatsc_e
14118         itypi=itype(i,1)
14119         if (itypi.eq.ntyp1) cycle
14120         itypi1=itype(i+1,1)
14121         xi=c(1,nres+i)
14122         yi=c(2,nres+i)
14123         zi=c(3,nres+i)
14124           xi=mod(xi,boxxsize)
14125           if (xi.lt.0) xi=xi+boxxsize
14126           yi=mod(yi,boxysize)
14127           if (yi.lt.0) yi=yi+boxysize
14128           zi=mod(zi,boxzsize)
14129           if (zi.lt.0) zi=zi+boxzsize
14130        if ((zi.gt.bordlipbot)    &
14131         .and.(zi.lt.bordliptop)) then
14132 !C the energy transfer exist
14133         if (zi.lt.buflipbot) then
14134 !C what fraction I am in
14135          fracinbuf=1.0d0-    &
14136              ((zi-bordlipbot)/lipbufthick)
14137 !C lipbufthick is thickenes of lipid buffore
14138          sslipi=sscalelip(fracinbuf)
14139          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14140         elseif (zi.gt.bufliptop) then
14141          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14142          sslipi=sscalelip(fracinbuf)
14143          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14144         else
14145          sslipi=1.0d0
14146          ssgradlipi=0.0
14147         endif
14148        else
14149          sslipi=0.0d0
14150          ssgradlipi=0.0
14151        endif
14152
14153         dxi=dc_norm(1,nres+i)
14154         dyi=dc_norm(2,nres+i)
14155         dzi=dc_norm(3,nres+i)
14156 !        dsci_inv=dsc_inv(itypi)
14157         dsci_inv=vbld_inv(i+nres)
14158
14159         dxi=dc_norm(1,nres+i)
14160         dyi=dc_norm(2,nres+i)
14161         dzi=dc_norm(3,nres+i)
14162 !        dsci_inv=dsc_inv(itypi)
14163         dsci_inv=vbld_inv(i+nres)
14164 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14165 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14166 !
14167 ! Calculate SC interaction energy.
14168 !
14169         do iint=1,nint_gr(i)
14170           do j=istart(i,iint),iend(i,iint)
14171             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14172               call dyn_ssbond_ene(i,j,evdwij)
14173               evdw=evdw+evdwij
14174               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14175                               'evdw',i,j,evdwij,' ss'
14176              do k=j+1,iend(i,iint)
14177 !C search over all next residues
14178               if (dyn_ss_mask(k)) then
14179 !C check if they are cysteins
14180 !C              write(iout,*) 'k=',k
14181
14182 !c              write(iout,*) "PRZED TRI", evdwij
14183 !               evdwij_przed_tri=evdwij
14184               call triple_ssbond_ene(i,j,k,evdwij)
14185 !c               if(evdwij_przed_tri.ne.evdwij) then
14186 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14187 !c               endif
14188
14189 !c              write(iout,*) "PO TRI", evdwij
14190 !C call the energy function that removes the artifical triple disulfide
14191 !C bond the soubroutine is located in ssMD.F
14192               evdw=evdw+evdwij
14193               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14194                             'evdw',i,j,evdwij,'tss'
14195               endif!dyn_ss_mask(k)
14196              enddo! k
14197
14198 !              if (energy_dec) write (iout,*) &
14199 !                              'evdw',i,j,evdwij,' ss'
14200             ELSE
14201 !el            ind=ind+1
14202             itypj=itype(j,1)
14203             if (itypj.eq.ntyp1) cycle
14204 !            dscj_inv=dsc_inv(itypj)
14205             dscj_inv=vbld_inv(j+nres)
14206 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14207 !     &       1.0d0/vbld(j+nres)
14208 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14209             sig0ij=sigma(itypi,itypj)
14210             chi1=chi(itypi,itypj)
14211             chi2=chi(itypj,itypi)
14212             chi12=chi1*chi2
14213             chip1=chip(itypi)
14214             chip2=chip(itypj)
14215             chip12=chip1*chip2
14216             alf1=alp(itypi)
14217             alf2=alp(itypj)
14218             alf12=0.5D0*(alf1+alf2)
14219 !            xj=c(1,nres+j)-xi
14220 !            yj=c(2,nres+j)-yi
14221 !            zj=c(3,nres+j)-zi
14222             xj=c(1,nres+j)
14223             yj=c(2,nres+j)
14224             zj=c(3,nres+j)
14225 ! Searching for nearest neighbour
14226           xj=mod(xj,boxxsize)
14227           if (xj.lt.0) xj=xj+boxxsize
14228           yj=mod(yj,boxysize)
14229           if (yj.lt.0) yj=yj+boxysize
14230           zj=mod(zj,boxzsize)
14231           if (zj.lt.0) zj=zj+boxzsize
14232        if ((zj.gt.bordlipbot)   &
14233       .and.(zj.lt.bordliptop)) then
14234 !C the energy transfer exist
14235         if (zj.lt.buflipbot) then
14236 !C what fraction I am in
14237          fracinbuf=1.0d0-  &
14238              ((zj-bordlipbot)/lipbufthick)
14239 !C lipbufthick is thickenes of lipid buffore
14240          sslipj=sscalelip(fracinbuf)
14241          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14242         elseif (zj.gt.bufliptop) then
14243          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14244          sslipj=sscalelip(fracinbuf)
14245          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14246         else
14247          sslipj=1.0d0
14248          ssgradlipj=0.0
14249         endif
14250        else
14251          sslipj=0.0d0
14252          ssgradlipj=0.0
14253        endif
14254       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14255        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14256       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14257        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14258
14259           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14260           xj_safe=xj
14261           yj_safe=yj
14262           zj_safe=zj
14263           subchap=0
14264
14265           do xshift=-1,1
14266           do yshift=-1,1
14267           do zshift=-1,1
14268           xj=xj_safe+xshift*boxxsize
14269           yj=yj_safe+yshift*boxysize
14270           zj=zj_safe+zshift*boxzsize
14271           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14272           if(dist_temp.lt.dist_init) then
14273             dist_init=dist_temp
14274             xj_temp=xj
14275             yj_temp=yj
14276             zj_temp=zj
14277             subchap=1
14278           endif
14279           enddo
14280           enddo
14281           enddo
14282           if (subchap.eq.1) then
14283           xj=xj_temp-xi
14284           yj=yj_temp-yi
14285           zj=zj_temp-zi
14286           else
14287           xj=xj_safe-xi
14288           yj=yj_safe-yi
14289           zj=zj_safe-zi
14290           endif
14291
14292             dxj=dc_norm(1,nres+j)
14293             dyj=dc_norm(2,nres+j)
14294             dzj=dc_norm(3,nres+j)
14295             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14296             rij=dsqrt(rrij)
14297             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14298             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14299             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
14300             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
14301             if (sss_ele_cut.le.0.0) cycle
14302
14303             if (sss.gt.0.0d0) then
14304
14305 ! Calculate angle-dependent terms of energy and contributions to their
14306 ! derivatives.
14307               call sc_angular
14308               sigsq=1.0D0/sigsq
14309               sig=sig0ij*dsqrt(sigsq)
14310               rij_shift=1.0D0/rij-sig+sig0ij
14311 ! for diagnostics; uncomment
14312 !              rij_shift=1.2*sig0ij
14313 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14314               if (rij_shift.le.0.0D0) then
14315                 evdw=1.0D20
14316 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14317 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14318 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14319                 return
14320               endif
14321               sigder=-sig*sigsq
14322 !---------------------------------------------------------------
14323               rij_shift=1.0D0/rij_shift
14324               fac=rij_shift**expon
14325               e1=fac*fac*aa
14326               e2=fac*bb
14327               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14328               eps2der=evdwij*eps3rt
14329               eps3der=evdwij*eps2rt
14330 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14331 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14332               evdwij=evdwij*eps2rt*eps3rt
14333               evdw=evdw+evdwij*sss*sss_ele_cut
14334               if (lprn) then
14335               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14336               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14337               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14338                 restyp(itypi,1),i,restyp(itypj,1),j,&
14339                 epsi,sigm,chi1,chi2,chip1,chip2,&
14340                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14341                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14342                 evdwij
14343               endif
14344
14345               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14346                               'evdw',i,j,evdwij
14347 !              if (energy_dec) write (iout,*) &
14348 !                              'evdw',i,j,evdwij,"egb_short"
14349
14350 ! Calculate gradient components.
14351               e1=e1*eps1*eps2rt**2*eps3rt**2
14352               fac=-expon*(e1+evdwij)*rij_shift
14353               sigder=fac*sigder
14354               fac=rij*fac
14355               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14356             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
14357             /sigmaii(itypi,itypj))
14358
14359 !              fac=0.0d0
14360 ! Calculate the radial part of the gradient
14361               gg(1)=xj*fac
14362               gg(2)=yj*fac
14363               gg(3)=zj*fac
14364 ! Calculate angular part of the gradient.
14365               call sc_grad_scale(sss)
14366             endif
14367           ENDIF !mask_dyn_ss
14368           enddo      ! j
14369         enddo        ! iint
14370       enddo          ! i
14371 !      write (iout,*) "Number of loop steps in EGB:",ind
14372 !ccc      energy_dec=.false.
14373       return
14374       end subroutine egb_short
14375 !-----------------------------------------------------------------------------
14376       subroutine egbv_long(evdw)
14377 !
14378 ! This subroutine calculates the interaction energy of nonbonded side chains
14379 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14380 !
14381       use calc_data
14382 !      implicit real*8 (a-h,o-z)
14383 !      include 'DIMENSIONS'
14384 !      include 'COMMON.GEO'
14385 !      include 'COMMON.VAR'
14386 !      include 'COMMON.LOCAL'
14387 !      include 'COMMON.CHAIN'
14388 !      include 'COMMON.DERIV'
14389 !      include 'COMMON.NAMES'
14390 !      include 'COMMON.INTERACT'
14391 !      include 'COMMON.IOUNITS'
14392 !      include 'COMMON.CALC'
14393       use comm_srutu
14394 !el      integer :: icall
14395 !el      common /srutu/ icall
14396       logical :: lprn
14397 !el local variables
14398       integer :: iint,itypi,itypi1,itypj
14399       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14400       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14401       evdw=0.0D0
14402 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14403       evdw=0.0D0
14404       lprn=.false.
14405 !     if (icall.eq.0) lprn=.true.
14406 !el      ind=0
14407       do i=iatsc_s,iatsc_e
14408         itypi=itype(i,1)
14409         if (itypi.eq.ntyp1) cycle
14410         itypi1=itype(i+1,1)
14411         xi=c(1,nres+i)
14412         yi=c(2,nres+i)
14413         zi=c(3,nres+i)
14414         dxi=dc_norm(1,nres+i)
14415         dyi=dc_norm(2,nres+i)
14416         dzi=dc_norm(3,nres+i)
14417 !        dsci_inv=dsc_inv(itypi)
14418         dsci_inv=vbld_inv(i+nres)
14419 !
14420 ! Calculate SC interaction energy.
14421 !
14422         do iint=1,nint_gr(i)
14423           do j=istart(i,iint),iend(i,iint)
14424 !el            ind=ind+1
14425             itypj=itype(j,1)
14426             if (itypj.eq.ntyp1) cycle
14427 !            dscj_inv=dsc_inv(itypj)
14428             dscj_inv=vbld_inv(j+nres)
14429             sig0ij=sigma(itypi,itypj)
14430             r0ij=r0(itypi,itypj)
14431             chi1=chi(itypi,itypj)
14432             chi2=chi(itypj,itypi)
14433             chi12=chi1*chi2
14434             chip1=chip(itypi)
14435             chip2=chip(itypj)
14436             chip12=chip1*chip2
14437             alf1=alp(itypi)
14438             alf2=alp(itypj)
14439             alf12=0.5D0*(alf1+alf2)
14440             xj=c(1,nres+j)-xi
14441             yj=c(2,nres+j)-yi
14442             zj=c(3,nres+j)-zi
14443             dxj=dc_norm(1,nres+j)
14444             dyj=dc_norm(2,nres+j)
14445             dzj=dc_norm(3,nres+j)
14446             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14447             rij=dsqrt(rrij)
14448
14449             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14450
14451             if (sss.lt.1.0d0) then
14452
14453 ! Calculate angle-dependent terms of energy and contributions to their
14454 ! derivatives.
14455               call sc_angular
14456               sigsq=1.0D0/sigsq
14457               sig=sig0ij*dsqrt(sigsq)
14458               rij_shift=1.0D0/rij-sig+r0ij
14459 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14460               if (rij_shift.le.0.0D0) then
14461                 evdw=1.0D20
14462                 return
14463               endif
14464               sigder=-sig*sigsq
14465 !---------------------------------------------------------------
14466               rij_shift=1.0D0/rij_shift
14467               fac=rij_shift**expon
14468               e1=fac*fac*aa_aq(itypi,itypj)
14469               e2=fac*bb_aq(itypi,itypj)
14470               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14471               eps2der=evdwij*eps3rt
14472               eps3der=evdwij*eps2rt
14473               fac_augm=rrij**expon
14474               e_augm=augm(itypi,itypj)*fac_augm
14475               evdwij=evdwij*eps2rt*eps3rt
14476               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14477               if (lprn) then
14478               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14479               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14480               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14481                 restyp(itypi,1),i,restyp(itypj,1),j,&
14482                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14483                 chi1,chi2,chip1,chip2,&
14484                 eps1,eps2rt**2,eps3rt**2,&
14485                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14486                 evdwij+e_augm
14487               endif
14488 ! Calculate gradient components.
14489               e1=e1*eps1*eps2rt**2*eps3rt**2
14490               fac=-expon*(e1+evdwij)*rij_shift
14491               sigder=fac*sigder
14492               fac=rij*fac-2*expon*rrij*e_augm
14493 ! Calculate the radial part of the gradient
14494               gg(1)=xj*fac
14495               gg(2)=yj*fac
14496               gg(3)=zj*fac
14497 ! Calculate angular part of the gradient.
14498               call sc_grad_scale(1.0d0-sss)
14499             endif
14500           enddo      ! j
14501         enddo        ! iint
14502       enddo          ! i
14503       end subroutine egbv_long
14504 !-----------------------------------------------------------------------------
14505       subroutine egbv_short(evdw)
14506 !
14507 ! This subroutine calculates the interaction energy of nonbonded side chains
14508 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14509 !
14510       use calc_data
14511 !      implicit real*8 (a-h,o-z)
14512 !      include 'DIMENSIONS'
14513 !      include 'COMMON.GEO'
14514 !      include 'COMMON.VAR'
14515 !      include 'COMMON.LOCAL'
14516 !      include 'COMMON.CHAIN'
14517 !      include 'COMMON.DERIV'
14518 !      include 'COMMON.NAMES'
14519 !      include 'COMMON.INTERACT'
14520 !      include 'COMMON.IOUNITS'
14521 !      include 'COMMON.CALC'
14522       use comm_srutu
14523 !el      integer :: icall
14524 !el      common /srutu/ icall
14525       logical :: lprn
14526 !el local variables
14527       integer :: iint,itypi,itypi1,itypj
14528       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14529       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14530       evdw=0.0D0
14531 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14532       evdw=0.0D0
14533       lprn=.false.
14534 !     if (icall.eq.0) lprn=.true.
14535 !el      ind=0
14536       do i=iatsc_s,iatsc_e
14537         itypi=itype(i,1)
14538         if (itypi.eq.ntyp1) cycle
14539         itypi1=itype(i+1,1)
14540         xi=c(1,nres+i)
14541         yi=c(2,nres+i)
14542         zi=c(3,nres+i)
14543         dxi=dc_norm(1,nres+i)
14544         dyi=dc_norm(2,nres+i)
14545         dzi=dc_norm(3,nres+i)
14546 !        dsci_inv=dsc_inv(itypi)
14547         dsci_inv=vbld_inv(i+nres)
14548 !
14549 ! Calculate SC interaction energy.
14550 !
14551         do iint=1,nint_gr(i)
14552           do j=istart(i,iint),iend(i,iint)
14553 !el            ind=ind+1
14554             itypj=itype(j,1)
14555             if (itypj.eq.ntyp1) cycle
14556 !            dscj_inv=dsc_inv(itypj)
14557             dscj_inv=vbld_inv(j+nres)
14558             sig0ij=sigma(itypi,itypj)
14559             r0ij=r0(itypi,itypj)
14560             chi1=chi(itypi,itypj)
14561             chi2=chi(itypj,itypi)
14562             chi12=chi1*chi2
14563             chip1=chip(itypi)
14564             chip2=chip(itypj)
14565             chip12=chip1*chip2
14566             alf1=alp(itypi)
14567             alf2=alp(itypj)
14568             alf12=0.5D0*(alf1+alf2)
14569             xj=c(1,nres+j)-xi
14570             yj=c(2,nres+j)-yi
14571             zj=c(3,nres+j)-zi
14572             dxj=dc_norm(1,nres+j)
14573             dyj=dc_norm(2,nres+j)
14574             dzj=dc_norm(3,nres+j)
14575             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14576             rij=dsqrt(rrij)
14577
14578             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14579
14580             if (sss.gt.0.0d0) then
14581
14582 ! Calculate angle-dependent terms of energy and contributions to their
14583 ! derivatives.
14584               call sc_angular
14585               sigsq=1.0D0/sigsq
14586               sig=sig0ij*dsqrt(sigsq)
14587               rij_shift=1.0D0/rij-sig+r0ij
14588 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14589               if (rij_shift.le.0.0D0) then
14590                 evdw=1.0D20
14591                 return
14592               endif
14593               sigder=-sig*sigsq
14594 !---------------------------------------------------------------
14595               rij_shift=1.0D0/rij_shift
14596               fac=rij_shift**expon
14597               e1=fac*fac*aa_aq(itypi,itypj)
14598               e2=fac*bb_aq(itypi,itypj)
14599               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14600               eps2der=evdwij*eps3rt
14601               eps3der=evdwij*eps2rt
14602               fac_augm=rrij**expon
14603               e_augm=augm(itypi,itypj)*fac_augm
14604               evdwij=evdwij*eps2rt*eps3rt
14605               evdw=evdw+(evdwij+e_augm)*sss
14606               if (lprn) then
14607               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14608               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14609               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14610                 restyp(itypi,1),i,restyp(itypj,1),j,&
14611                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14612                 chi1,chi2,chip1,chip2,&
14613                 eps1,eps2rt**2,eps3rt**2,&
14614                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14615                 evdwij+e_augm
14616               endif
14617 ! Calculate gradient components.
14618               e1=e1*eps1*eps2rt**2*eps3rt**2
14619               fac=-expon*(e1+evdwij)*rij_shift
14620               sigder=fac*sigder
14621               fac=rij*fac-2*expon*rrij*e_augm
14622 ! Calculate the radial part of the gradient
14623               gg(1)=xj*fac
14624               gg(2)=yj*fac
14625               gg(3)=zj*fac
14626 ! Calculate angular part of the gradient.
14627               call sc_grad_scale(sss)
14628             endif
14629           enddo      ! j
14630         enddo        ! iint
14631       enddo          ! i
14632       end subroutine egbv_short
14633 !-----------------------------------------------------------------------------
14634       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14635 !
14636 ! This subroutine calculates the average interaction energy and its gradient
14637 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14638 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14639 ! The potential depends both on the distance of peptide-group centers and on
14640 ! the orientation of the CA-CA virtual bonds.
14641 !
14642 !      implicit real*8 (a-h,o-z)
14643
14644       use comm_locel
14645 #ifdef MPI
14646       include 'mpif.h'
14647 #endif
14648 !      include 'DIMENSIONS'
14649 !      include 'COMMON.CONTROL'
14650 !      include 'COMMON.SETUP'
14651 !      include 'COMMON.IOUNITS'
14652 !      include 'COMMON.GEO'
14653 !      include 'COMMON.VAR'
14654 !      include 'COMMON.LOCAL'
14655 !      include 'COMMON.CHAIN'
14656 !      include 'COMMON.DERIV'
14657 !      include 'COMMON.INTERACT'
14658 !      include 'COMMON.CONTACTS'
14659 !      include 'COMMON.TORSION'
14660 !      include 'COMMON.VECTORS'
14661 !      include 'COMMON.FFIELD'
14662 !      include 'COMMON.TIME1'
14663       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14664       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14665       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14666 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14667       real(kind=8),dimension(4) :: muij
14668 !el      integer :: num_conti,j1,j2
14669 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14670 !el                   dz_normi,xmedi,ymedi,zmedi
14671 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14672 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14673 !el          num_conti,j1,j2
14674 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14675 #ifdef MOMENT
14676       real(kind=8) :: scal_el=1.0d0
14677 #else
14678       real(kind=8) :: scal_el=0.5d0
14679 #endif
14680 ! 12/13/98
14681 ! 13-go grudnia roku pamietnego...
14682       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14683                                              0.0d0,1.0d0,0.0d0,&
14684                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14685 !el local variables
14686       integer :: i,j,k
14687       real(kind=8) :: fac
14688       real(kind=8) :: dxj,dyj,dzj
14689       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14690
14691 !      allocate(num_cont_hb(nres)) !(maxres)
14692 !d      write(iout,*) 'In EELEC'
14693 !d      do i=1,nloctyp
14694 !d        write(iout,*) 'Type',i
14695 !d        write(iout,*) 'B1',B1(:,i)
14696 !d        write(iout,*) 'B2',B2(:,i)
14697 !d        write(iout,*) 'CC',CC(:,:,i)
14698 !d        write(iout,*) 'DD',DD(:,:,i)
14699 !d        write(iout,*) 'EE',EE(:,:,i)
14700 !d      enddo
14701 !d      call check_vecgrad
14702 !d      stop
14703       if (icheckgrad.eq.1) then
14704         do i=1,nres-1
14705           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14706           do k=1,3
14707             dc_norm(k,i)=dc(k,i)*fac
14708           enddo
14709 !          write (iout,*) 'i',i,' fac',fac
14710         enddo
14711       endif
14712       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14713           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14714           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14715 !        call vec_and_deriv
14716 #ifdef TIMING
14717         time01=MPI_Wtime()
14718 #endif
14719 !        print *, "before set matrices"
14720         call set_matrices
14721 !        print *,"after set martices"
14722 #ifdef TIMING
14723         time_mat=time_mat+MPI_Wtime()-time01
14724 #endif
14725       endif
14726 !d      do i=1,nres-1
14727 !d        write (iout,*) 'i=',i
14728 !d        do k=1,3
14729 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14730 !d        enddo
14731 !d        do k=1,3
14732 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14733 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14734 !d        enddo
14735 !d      enddo
14736       t_eelecij=0.0d0
14737       ees=0.0D0
14738       evdw1=0.0D0
14739       eel_loc=0.0d0
14740       eello_turn3=0.0d0
14741       eello_turn4=0.0d0
14742 !el      ind=0
14743       do i=1,nres
14744         num_cont_hb(i)=0
14745       enddo
14746 !d      print '(a)','Enter EELEC'
14747 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14748 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14749 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14750       do i=1,nres
14751         gel_loc_loc(i)=0.0d0
14752         gcorr_loc(i)=0.0d0
14753       enddo
14754 !
14755 !
14756 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14757 !
14758 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14759 !
14760       do i=iturn3_start,iturn3_end
14761         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14762         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14763         dxi=dc(1,i)
14764         dyi=dc(2,i)
14765         dzi=dc(3,i)
14766         dx_normi=dc_norm(1,i)
14767         dy_normi=dc_norm(2,i)
14768         dz_normi=dc_norm(3,i)
14769         xmedi=c(1,i)+0.5d0*dxi
14770         ymedi=c(2,i)+0.5d0*dyi
14771         zmedi=c(3,i)+0.5d0*dzi
14772           xmedi=dmod(xmedi,boxxsize)
14773           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14774           ymedi=dmod(ymedi,boxysize)
14775           if (ymedi.lt.0) ymedi=ymedi+boxysize
14776           zmedi=dmod(zmedi,boxzsize)
14777           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14778         num_conti=0
14779         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14780         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14781         num_cont_hb(i)=num_conti
14782       enddo
14783       do i=iturn4_start,iturn4_end
14784         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14785           .or. itype(i+3,1).eq.ntyp1 &
14786           .or. itype(i+4,1).eq.ntyp1) cycle
14787         dxi=dc(1,i)
14788         dyi=dc(2,i)
14789         dzi=dc(3,i)
14790         dx_normi=dc_norm(1,i)
14791         dy_normi=dc_norm(2,i)
14792         dz_normi=dc_norm(3,i)
14793         xmedi=c(1,i)+0.5d0*dxi
14794         ymedi=c(2,i)+0.5d0*dyi
14795         zmedi=c(3,i)+0.5d0*dzi
14796           xmedi=dmod(xmedi,boxxsize)
14797           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14798           ymedi=dmod(ymedi,boxysize)
14799           if (ymedi.lt.0) ymedi=ymedi+boxysize
14800           zmedi=dmod(zmedi,boxzsize)
14801           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14802         num_conti=num_cont_hb(i)
14803         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14804         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14805           call eturn4(i,eello_turn4)
14806         num_cont_hb(i)=num_conti
14807       enddo   ! i
14808 !
14809 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14810 !
14811       do i=iatel_s,iatel_e
14812         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14813         dxi=dc(1,i)
14814         dyi=dc(2,i)
14815         dzi=dc(3,i)
14816         dx_normi=dc_norm(1,i)
14817         dy_normi=dc_norm(2,i)
14818         dz_normi=dc_norm(3,i)
14819         xmedi=c(1,i)+0.5d0*dxi
14820         ymedi=c(2,i)+0.5d0*dyi
14821         zmedi=c(3,i)+0.5d0*dzi
14822           xmedi=dmod(xmedi,boxxsize)
14823           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14824           ymedi=dmod(ymedi,boxysize)
14825           if (ymedi.lt.0) ymedi=ymedi+boxysize
14826           zmedi=dmod(zmedi,boxzsize)
14827           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14828 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14829         num_conti=num_cont_hb(i)
14830         do j=ielstart(i),ielend(i)
14831           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14832           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14833         enddo ! j
14834         num_cont_hb(i)=num_conti
14835       enddo   ! i
14836 !      write (iout,*) "Number of loop steps in EELEC:",ind
14837 !d      do i=1,nres
14838 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14839 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14840 !d      enddo
14841 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14842 !cc      eel_loc=eel_loc+eello_turn3
14843 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14844       return
14845       end subroutine eelec_scale
14846 !-----------------------------------------------------------------------------
14847       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14848 !      implicit real*8 (a-h,o-z)
14849
14850       use comm_locel
14851 !      include 'DIMENSIONS'
14852 #ifdef MPI
14853       include "mpif.h"
14854 #endif
14855 !      include 'COMMON.CONTROL'
14856 !      include 'COMMON.IOUNITS'
14857 !      include 'COMMON.GEO'
14858 !      include 'COMMON.VAR'
14859 !      include 'COMMON.LOCAL'
14860 !      include 'COMMON.CHAIN'
14861 !      include 'COMMON.DERIV'
14862 !      include 'COMMON.INTERACT'
14863 !      include 'COMMON.CONTACTS'
14864 !      include 'COMMON.TORSION'
14865 !      include 'COMMON.VECTORS'
14866 !      include 'COMMON.FFIELD'
14867 !      include 'COMMON.TIME1'
14868       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14869       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14870       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14871 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14872       real(kind=8),dimension(4) :: muij
14873       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14874                     dist_temp, dist_init,sss_grad
14875       integer xshift,yshift,zshift
14876
14877 !el      integer :: num_conti,j1,j2
14878 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14879 !el                   dz_normi,xmedi,ymedi,zmedi
14880 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14881 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14882 !el          num_conti,j1,j2
14883 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14884 #ifdef MOMENT
14885       real(kind=8) :: scal_el=1.0d0
14886 #else
14887       real(kind=8) :: scal_el=0.5d0
14888 #endif
14889 ! 12/13/98
14890 ! 13-go grudnia roku pamietnego...
14891       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14892                                              0.0d0,1.0d0,0.0d0,&
14893                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14894 !el local variables
14895       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14896       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14897       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14898       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14899       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14900       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14901       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14902                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14903                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14904                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14905                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14906                   ecosam,ecosbm,ecosgm,ghalf,time00
14907 !      integer :: maxconts
14908 !      maxconts = nres/4
14909 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14910 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14911 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14912 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14913 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14914 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14915 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14916 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14917 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14918 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14919 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14920 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14921 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14922
14923 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14924 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14925
14926 #ifdef MPI
14927           time00=MPI_Wtime()
14928 #endif
14929 !d      write (iout,*) "eelecij",i,j
14930 !el          ind=ind+1
14931           iteli=itel(i)
14932           itelj=itel(j)
14933           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14934           aaa=app(iteli,itelj)
14935           bbb=bpp(iteli,itelj)
14936           ael6i=ael6(iteli,itelj)
14937           ael3i=ael3(iteli,itelj)
14938           dxj=dc(1,j)
14939           dyj=dc(2,j)
14940           dzj=dc(3,j)
14941           dx_normj=dc_norm(1,j)
14942           dy_normj=dc_norm(2,j)
14943           dz_normj=dc_norm(3,j)
14944 !          xj=c(1,j)+0.5D0*dxj-xmedi
14945 !          yj=c(2,j)+0.5D0*dyj-ymedi
14946 !          zj=c(3,j)+0.5D0*dzj-zmedi
14947           xj=c(1,j)+0.5D0*dxj
14948           yj=c(2,j)+0.5D0*dyj
14949           zj=c(3,j)+0.5D0*dzj
14950           xj=mod(xj,boxxsize)
14951           if (xj.lt.0) xj=xj+boxxsize
14952           yj=mod(yj,boxysize)
14953           if (yj.lt.0) yj=yj+boxysize
14954           zj=mod(zj,boxzsize)
14955           if (zj.lt.0) zj=zj+boxzsize
14956       isubchap=0
14957       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14958       xj_safe=xj
14959       yj_safe=yj
14960       zj_safe=zj
14961       do xshift=-1,1
14962       do yshift=-1,1
14963       do zshift=-1,1
14964           xj=xj_safe+xshift*boxxsize
14965           yj=yj_safe+yshift*boxysize
14966           zj=zj_safe+zshift*boxzsize
14967           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14968           if(dist_temp.lt.dist_init) then
14969             dist_init=dist_temp
14970             xj_temp=xj
14971             yj_temp=yj
14972             zj_temp=zj
14973             isubchap=1
14974           endif
14975        enddo
14976        enddo
14977        enddo
14978        if (isubchap.eq.1) then
14979 !C          print *,i,j
14980           xj=xj_temp-xmedi
14981           yj=yj_temp-ymedi
14982           zj=zj_temp-zmedi
14983        else
14984           xj=xj_safe-xmedi
14985           yj=yj_safe-ymedi
14986           zj=zj_safe-zmedi
14987        endif
14988
14989           rij=xj*xj+yj*yj+zj*zj
14990           rrmij=1.0D0/rij
14991           rij=dsqrt(rij)
14992           rmij=1.0D0/rij
14993 ! For extracting the short-range part of Evdwpp
14994           sss=sscale(rij/rpp(iteli,itelj))
14995             sss_ele_cut=sscale_ele(rij)
14996             sss_ele_grad=sscagrad_ele(rij)
14997             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14998 !             sss_ele_cut=1.0d0
14999 !             sss_ele_grad=0.0d0
15000             if (sss_ele_cut.le.0.0) go to 128
15001
15002           r3ij=rrmij*rmij
15003           r6ij=r3ij*r3ij
15004           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15005           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15006           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15007           fac=cosa-3.0D0*cosb*cosg
15008           ev1=aaa*r6ij*r6ij
15009 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15010           if (j.eq.i+2) ev1=scal_el*ev1
15011           ev2=bbb*r6ij
15012           fac3=ael6i*r6ij
15013           fac4=ael3i*r3ij
15014           evdwij=ev1+ev2
15015           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15016           el2=fac4*fac
15017           eesij=el1+el2
15018 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15019           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15020           ees=ees+eesij*sss_ele_cut
15021           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15022 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15023 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15024 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15025 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15026
15027           if (energy_dec) then
15028               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15029               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15030           endif
15031
15032 !
15033 ! Calculate contributions to the Cartesian gradient.
15034 !
15035 #ifdef SPLITELE
15036           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15037           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15038           fac1=fac
15039           erij(1)=xj*rmij
15040           erij(2)=yj*rmij
15041           erij(3)=zj*rmij
15042 !
15043 ! Radial derivatives. First process both termini of the fragment (i,j)
15044 !
15045           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15046           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15047           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15048 !          do k=1,3
15049 !            ghalf=0.5D0*ggg(k)
15050 !            gelc(k,i)=gelc(k,i)+ghalf
15051 !            gelc(k,j)=gelc(k,j)+ghalf
15052 !          enddo
15053 ! 9/28/08 AL Gradient compotents will be summed only at the end
15054           do k=1,3
15055             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15056             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15057           enddo
15058 !
15059 ! Loop over residues i+1 thru j-1.
15060 !
15061 !grad          do k=i+1,j-1
15062 !grad            do l=1,3
15063 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15064 !grad            enddo
15065 !grad          enddo
15066           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15067           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15068           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15069           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15070           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15071           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15072 !          do k=1,3
15073 !            ghalf=0.5D0*ggg(k)
15074 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15075 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15076 !          enddo
15077 ! 9/28/08 AL Gradient compotents will be summed only at the end
15078           do k=1,3
15079             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15080             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15081           enddo
15082 !
15083 ! Loop over residues i+1 thru j-1.
15084 !
15085 !grad          do k=i+1,j-1
15086 !grad            do l=1,3
15087 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15088 !grad            enddo
15089 !grad          enddo
15090 #else
15091           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15092           facel=(el1+eesij)*sss_ele_cut
15093           fac1=fac
15094           fac=-3*rrmij*(facvdw+facvdw+facel)
15095           erij(1)=xj*rmij
15096           erij(2)=yj*rmij
15097           erij(3)=zj*rmij
15098 !
15099 ! Radial derivatives. First process both termini of the fragment (i,j)
15100 !
15101           ggg(1)=fac*xj
15102           ggg(2)=fac*yj
15103           ggg(3)=fac*zj
15104 !          do k=1,3
15105 !            ghalf=0.5D0*ggg(k)
15106 !            gelc(k,i)=gelc(k,i)+ghalf
15107 !            gelc(k,j)=gelc(k,j)+ghalf
15108 !          enddo
15109 ! 9/28/08 AL Gradient compotents will be summed only at the end
15110           do k=1,3
15111             gelc_long(k,j)=gelc(k,j)+ggg(k)
15112             gelc_long(k,i)=gelc(k,i)-ggg(k)
15113           enddo
15114 !
15115 ! Loop over residues i+1 thru j-1.
15116 !
15117 !grad          do k=i+1,j-1
15118 !grad            do l=1,3
15119 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15120 !grad            enddo
15121 !grad          enddo
15122 ! 9/28/08 AL Gradient compotents will be summed only at the end
15123           ggg(1)=facvdw*xj
15124           ggg(2)=facvdw*yj
15125           ggg(3)=facvdw*zj
15126           do k=1,3
15127             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15128             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15129           enddo
15130 #endif
15131 !
15132 ! Angular part
15133 !
15134           ecosa=2.0D0*fac3*fac1+fac4
15135           fac4=-3.0D0*fac4
15136           fac3=-6.0D0*fac3
15137           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15138           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15139           do k=1,3
15140             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15141             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15142           enddo
15143 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15144 !d   &          (dcosg(k),k=1,3)
15145           do k=1,3
15146             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15147           enddo
15148 !          do k=1,3
15149 !            ghalf=0.5D0*ggg(k)
15150 !            gelc(k,i)=gelc(k,i)+ghalf
15151 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15152 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15153 !            gelc(k,j)=gelc(k,j)+ghalf
15154 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15155 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15156 !          enddo
15157 !grad          do k=i+1,j-1
15158 !grad            do l=1,3
15159 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15160 !grad            enddo
15161 !grad          enddo
15162           do k=1,3
15163             gelc(k,i)=gelc(k,i) &
15164                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15165                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15166                      *sss_ele_cut
15167             gelc(k,j)=gelc(k,j) &
15168                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15169                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15170                      *sss_ele_cut
15171             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15172             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15173           enddo
15174           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15175               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15176               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15177 !
15178 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15179 !   energy of a peptide unit is assumed in the form of a second-order
15180 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15181 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15182 !   are computed for EVERY pair of non-contiguous peptide groups.
15183 !
15184           if (j.lt.nres-1) then
15185             j1=j+1
15186             j2=j-1
15187           else
15188             j1=j-1
15189             j2=j-2
15190           endif
15191           kkk=0
15192           do k=1,2
15193             do l=1,2
15194               kkk=kkk+1
15195               muij(kkk)=mu(k,i)*mu(l,j)
15196             enddo
15197           enddo
15198 !d         write (iout,*) 'EELEC: i',i,' j',j
15199 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15200 !d          write(iout,*) 'muij',muij
15201           ury=scalar(uy(1,i),erij)
15202           urz=scalar(uz(1,i),erij)
15203           vry=scalar(uy(1,j),erij)
15204           vrz=scalar(uz(1,j),erij)
15205           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15206           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15207           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15208           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15209           fac=dsqrt(-ael6i)*r3ij
15210           a22=a22*fac
15211           a23=a23*fac
15212           a32=a32*fac
15213           a33=a33*fac
15214 !d          write (iout,'(4i5,4f10.5)')
15215 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15216 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15217 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15218 !d     &      uy(:,j),uz(:,j)
15219 !d          write (iout,'(4f10.5)')
15220 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15221 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15222 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15223 !d           write (iout,'(9f10.5/)')
15224 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15225 ! Derivatives of the elements of A in virtual-bond vectors
15226           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15227           do k=1,3
15228             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15229             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15230             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15231             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15232             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15233             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15234             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15235             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15236             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15237             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15238             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15239             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15240           enddo
15241 ! Compute radial contributions to the gradient
15242           facr=-3.0d0*rrmij
15243           a22der=a22*facr
15244           a23der=a23*facr
15245           a32der=a32*facr
15246           a33der=a33*facr
15247           agg(1,1)=a22der*xj
15248           agg(2,1)=a22der*yj
15249           agg(3,1)=a22der*zj
15250           agg(1,2)=a23der*xj
15251           agg(2,2)=a23der*yj
15252           agg(3,2)=a23der*zj
15253           agg(1,3)=a32der*xj
15254           agg(2,3)=a32der*yj
15255           agg(3,3)=a32der*zj
15256           agg(1,4)=a33der*xj
15257           agg(2,4)=a33der*yj
15258           agg(3,4)=a33der*zj
15259 ! Add the contributions coming from er
15260           fac3=-3.0d0*fac
15261           do k=1,3
15262             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15263             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15264             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15265             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15266           enddo
15267           do k=1,3
15268 ! Derivatives in DC(i)
15269 !grad            ghalf1=0.5d0*agg(k,1)
15270 !grad            ghalf2=0.5d0*agg(k,2)
15271 !grad            ghalf3=0.5d0*agg(k,3)
15272 !grad            ghalf4=0.5d0*agg(k,4)
15273             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15274             -3.0d0*uryg(k,2)*vry)!+ghalf1
15275             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15276             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15277             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15278             -3.0d0*urzg(k,2)*vry)!+ghalf3
15279             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15280             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15281 ! Derivatives in DC(i+1)
15282             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15283             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15284             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15285             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15286             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15287             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15288             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15289             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15290 ! Derivatives in DC(j)
15291             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15292             -3.0d0*vryg(k,2)*ury)!+ghalf1
15293             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15294             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15295             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15296             -3.0d0*vryg(k,2)*urz)!+ghalf3
15297             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15298             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15299 ! Derivatives in DC(j+1) or DC(nres-1)
15300             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15301             -3.0d0*vryg(k,3)*ury)
15302             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15303             -3.0d0*vrzg(k,3)*ury)
15304             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15305             -3.0d0*vryg(k,3)*urz)
15306             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15307             -3.0d0*vrzg(k,3)*urz)
15308 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15309 !grad              do l=1,4
15310 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15311 !grad              enddo
15312 !grad            endif
15313           enddo
15314           acipa(1,1)=a22
15315           acipa(1,2)=a23
15316           acipa(2,1)=a32
15317           acipa(2,2)=a33
15318           a22=-a22
15319           a23=-a23
15320           do l=1,2
15321             do k=1,3
15322               agg(k,l)=-agg(k,l)
15323               aggi(k,l)=-aggi(k,l)
15324               aggi1(k,l)=-aggi1(k,l)
15325               aggj(k,l)=-aggj(k,l)
15326               aggj1(k,l)=-aggj1(k,l)
15327             enddo
15328           enddo
15329           if (j.lt.nres-1) then
15330             a22=-a22
15331             a32=-a32
15332             do l=1,3,2
15333               do k=1,3
15334                 agg(k,l)=-agg(k,l)
15335                 aggi(k,l)=-aggi(k,l)
15336                 aggi1(k,l)=-aggi1(k,l)
15337                 aggj(k,l)=-aggj(k,l)
15338                 aggj1(k,l)=-aggj1(k,l)
15339               enddo
15340             enddo
15341           else
15342             a22=-a22
15343             a23=-a23
15344             a32=-a32
15345             a33=-a33
15346             do l=1,4
15347               do k=1,3
15348                 agg(k,l)=-agg(k,l)
15349                 aggi(k,l)=-aggi(k,l)
15350                 aggi1(k,l)=-aggi1(k,l)
15351                 aggj(k,l)=-aggj(k,l)
15352                 aggj1(k,l)=-aggj1(k,l)
15353               enddo
15354             enddo
15355           endif
15356           ENDIF ! WCORR
15357           IF (wel_loc.gt.0.0d0) THEN
15358 ! Contribution to the local-electrostatic energy coming from the i-j pair
15359           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15360            +a33*muij(4)
15361 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15362 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15363           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15364                   'eelloc',i,j,eel_loc_ij
15365 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15366
15367           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15368 ! Partial derivatives in virtual-bond dihedral angles gamma
15369           if (i.gt.1) &
15370           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15371                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15372                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15373                  *sss_ele_cut
15374           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15375                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15376                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15377                  *sss_ele_cut
15378            xtemp(1)=xj
15379            xtemp(2)=yj
15380            xtemp(3)=zj
15381
15382 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15383           do l=1,3
15384             ggg(l)=(agg(l,1)*muij(1)+ &
15385                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15386             *sss_ele_cut &
15387              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15388
15389             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15390             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15391 !grad            ghalf=0.5d0*ggg(l)
15392 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15393 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15394           enddo
15395 !grad          do k=i+1,j2
15396 !grad            do l=1,3
15397 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15398 !grad            enddo
15399 !grad          enddo
15400 ! Remaining derivatives of eello
15401           do l=1,3
15402             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15403                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15404             *sss_ele_cut
15405
15406             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15407                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15408             *sss_ele_cut
15409
15410             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15411                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15412             *sss_ele_cut
15413
15414             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15415                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15416             *sss_ele_cut
15417
15418           enddo
15419           ENDIF
15420 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15421 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15422           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15423              .and. num_conti.le.maxconts) then
15424 !            write (iout,*) i,j," entered corr"
15425 !
15426 ! Calculate the contact function. The ith column of the array JCONT will
15427 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15428 ! greater than I). The arrays FACONT and GACONT will contain the values of
15429 ! the contact function and its derivative.
15430 !           r0ij=1.02D0*rpp(iteli,itelj)
15431 !           r0ij=1.11D0*rpp(iteli,itelj)
15432             r0ij=2.20D0*rpp(iteli,itelj)
15433 !           r0ij=1.55D0*rpp(iteli,itelj)
15434             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15435 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15436             if (fcont.gt.0.0D0) then
15437               num_conti=num_conti+1
15438               if (num_conti.gt.maxconts) then
15439 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15440                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15441                                ' will skip next contacts for this conf.',num_conti
15442               else
15443                 jcont_hb(num_conti,i)=j
15444 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15445 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15446                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15447                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15448 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15449 !  terms.
15450                 d_cont(num_conti,i)=rij
15451 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15452 !     --- Electrostatic-interaction matrix ---
15453                 a_chuj(1,1,num_conti,i)=a22
15454                 a_chuj(1,2,num_conti,i)=a23
15455                 a_chuj(2,1,num_conti,i)=a32
15456                 a_chuj(2,2,num_conti,i)=a33
15457 !     --- Gradient of rij
15458                 do kkk=1,3
15459                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15460                 enddo
15461                 kkll=0
15462                 do k=1,2
15463                   do l=1,2
15464                     kkll=kkll+1
15465                     do m=1,3
15466                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15467                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15468                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15469                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15470                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15471                     enddo
15472                   enddo
15473                 enddo
15474                 ENDIF
15475                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15476 ! Calculate contact energies
15477                 cosa4=4.0D0*cosa
15478                 wij=cosa-3.0D0*cosb*cosg
15479                 cosbg1=cosb+cosg
15480                 cosbg2=cosb-cosg
15481 !               fac3=dsqrt(-ael6i)/r0ij**3
15482                 fac3=dsqrt(-ael6i)*r3ij
15483 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15484                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15485                 if (ees0tmp.gt.0) then
15486                   ees0pij=dsqrt(ees0tmp)
15487                 else
15488                   ees0pij=0
15489                 endif
15490 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15491                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15492                 if (ees0tmp.gt.0) then
15493                   ees0mij=dsqrt(ees0tmp)
15494                 else
15495                   ees0mij=0
15496                 endif
15497 !               ees0mij=0.0D0
15498                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15499                      *sss_ele_cut
15500
15501                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15502                      *sss_ele_cut
15503
15504 ! Diagnostics. Comment out or remove after debugging!
15505 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15506 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15507 !               ees0m(num_conti,i)=0.0D0
15508 ! End diagnostics.
15509 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15510 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15511 ! Angular derivatives of the contact function
15512                 ees0pij1=fac3/ees0pij
15513                 ees0mij1=fac3/ees0mij
15514                 fac3p=-3.0D0*fac3*rrmij
15515                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15516                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15517 !               ees0mij1=0.0D0
15518                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15519                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15520                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15521                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15522                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15523                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15524                 ecosap=ecosa1+ecosa2
15525                 ecosbp=ecosb1+ecosb2
15526                 ecosgp=ecosg1+ecosg2
15527                 ecosam=ecosa1-ecosa2
15528                 ecosbm=ecosb1-ecosb2
15529                 ecosgm=ecosg1-ecosg2
15530 ! Diagnostics
15531 !               ecosap=ecosa1
15532 !               ecosbp=ecosb1
15533 !               ecosgp=ecosg1
15534 !               ecosam=0.0D0
15535 !               ecosbm=0.0D0
15536 !               ecosgm=0.0D0
15537 ! End diagnostics
15538                 facont_hb(num_conti,i)=fcont
15539                 fprimcont=fprimcont/rij
15540 !d              facont_hb(num_conti,i)=1.0D0
15541 ! Following line is for diagnostics.
15542 !d              fprimcont=0.0D0
15543                 do k=1,3
15544                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15545                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15546                 enddo
15547                 do k=1,3
15548                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15549                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15550                 enddo
15551 !                gggp(1)=gggp(1)+ees0pijp*xj
15552 !                gggp(2)=gggp(2)+ees0pijp*yj
15553 !                gggp(3)=gggp(3)+ees0pijp*zj
15554 !                gggm(1)=gggm(1)+ees0mijp*xj
15555 !                gggm(2)=gggm(2)+ees0mijp*yj
15556 !                gggm(3)=gggm(3)+ees0mijp*zj
15557                 gggp(1)=gggp(1)+ees0pijp*xj &
15558                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15559                 gggp(2)=gggp(2)+ees0pijp*yj &
15560                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15561                 gggp(3)=gggp(3)+ees0pijp*zj &
15562                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15563
15564                 gggm(1)=gggm(1)+ees0mijp*xj &
15565                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15566
15567                 gggm(2)=gggm(2)+ees0mijp*yj &
15568                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15569
15570                 gggm(3)=gggm(3)+ees0mijp*zj &
15571                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15572
15573 ! Derivatives due to the contact function
15574                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15575                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15576                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15577                 do k=1,3
15578 !
15579 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15580 !          following the change of gradient-summation algorithm.
15581 !
15582 !grad                  ghalfp=0.5D0*gggp(k)
15583 !grad                  ghalfm=0.5D0*gggm(k)
15584 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15585 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15586 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15587 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15588 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15589 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15590 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15591 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15592 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15593 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15594 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15595 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15596 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15597 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15598                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15599                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15600                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15601                      *sss_ele_cut
15602
15603                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15604                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15605                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15606                      *sss_ele_cut
15607
15608                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15609                      *sss_ele_cut
15610
15611                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15612                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15613                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15614                      *sss_ele_cut
15615
15616                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15617                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15618                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15619                      *sss_ele_cut
15620
15621                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15622                      *sss_ele_cut
15623
15624                 enddo
15625               ENDIF ! wcorr
15626               endif  ! num_conti.le.maxconts
15627             endif  ! fcont.gt.0
15628           endif    ! j.gt.i+1
15629           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15630             do k=1,4
15631               do l=1,3
15632                 ghalf=0.5d0*agg(l,k)
15633                 aggi(l,k)=aggi(l,k)+ghalf
15634                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15635                 aggj(l,k)=aggj(l,k)+ghalf
15636               enddo
15637             enddo
15638             if (j.eq.nres-1 .and. i.lt.j-2) then
15639               do k=1,4
15640                 do l=1,3
15641                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15642                 enddo
15643               enddo
15644             endif
15645           endif
15646  128      continue
15647 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15648       return
15649       end subroutine eelecij_scale
15650 !-----------------------------------------------------------------------------
15651       subroutine evdwpp_short(evdw1)
15652 !
15653 ! Compute Evdwpp
15654 !
15655 !      implicit real*8 (a-h,o-z)
15656 !      include 'DIMENSIONS'
15657 !      include 'COMMON.CONTROL'
15658 !      include 'COMMON.IOUNITS'
15659 !      include 'COMMON.GEO'
15660 !      include 'COMMON.VAR'
15661 !      include 'COMMON.LOCAL'
15662 !      include 'COMMON.CHAIN'
15663 !      include 'COMMON.DERIV'
15664 !      include 'COMMON.INTERACT'
15665 !      include 'COMMON.CONTACTS'
15666 !      include 'COMMON.TORSION'
15667 !      include 'COMMON.VECTORS'
15668 !      include 'COMMON.FFIELD'
15669       real(kind=8),dimension(3) :: ggg
15670 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15671 #ifdef MOMENT
15672       real(kind=8) :: scal_el=1.0d0
15673 #else
15674       real(kind=8) :: scal_el=0.5d0
15675 #endif
15676 !el local variables
15677       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15678       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15679       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15680                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15681                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15682       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15683                     dist_temp, dist_init,sss_grad
15684       integer xshift,yshift,zshift
15685
15686
15687       evdw1=0.0D0
15688 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15689 !     & " iatel_e_vdw",iatel_e_vdw
15690       call flush(iout)
15691       do i=iatel_s_vdw,iatel_e_vdw
15692         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15693         dxi=dc(1,i)
15694         dyi=dc(2,i)
15695         dzi=dc(3,i)
15696         dx_normi=dc_norm(1,i)
15697         dy_normi=dc_norm(2,i)
15698         dz_normi=dc_norm(3,i)
15699         xmedi=c(1,i)+0.5d0*dxi
15700         ymedi=c(2,i)+0.5d0*dyi
15701         zmedi=c(3,i)+0.5d0*dzi
15702           xmedi=dmod(xmedi,boxxsize)
15703           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15704           ymedi=dmod(ymedi,boxysize)
15705           if (ymedi.lt.0) ymedi=ymedi+boxysize
15706           zmedi=dmod(zmedi,boxzsize)
15707           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15708         num_conti=0
15709 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15710 !     &   ' ielend',ielend_vdw(i)
15711         call flush(iout)
15712         do j=ielstart_vdw(i),ielend_vdw(i)
15713           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15714 !el          ind=ind+1
15715           iteli=itel(i)
15716           itelj=itel(j)
15717           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15718           aaa=app(iteli,itelj)
15719           bbb=bpp(iteli,itelj)
15720           dxj=dc(1,j)
15721           dyj=dc(2,j)
15722           dzj=dc(3,j)
15723           dx_normj=dc_norm(1,j)
15724           dy_normj=dc_norm(2,j)
15725           dz_normj=dc_norm(3,j)
15726 !          xj=c(1,j)+0.5D0*dxj-xmedi
15727 !          yj=c(2,j)+0.5D0*dyj-ymedi
15728 !          zj=c(3,j)+0.5D0*dzj-zmedi
15729           xj=c(1,j)+0.5D0*dxj
15730           yj=c(2,j)+0.5D0*dyj
15731           zj=c(3,j)+0.5D0*dzj
15732           xj=mod(xj,boxxsize)
15733           if (xj.lt.0) xj=xj+boxxsize
15734           yj=mod(yj,boxysize)
15735           if (yj.lt.0) yj=yj+boxysize
15736           zj=mod(zj,boxzsize)
15737           if (zj.lt.0) zj=zj+boxzsize
15738       isubchap=0
15739       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15740       xj_safe=xj
15741       yj_safe=yj
15742       zj_safe=zj
15743       do xshift=-1,1
15744       do yshift=-1,1
15745       do zshift=-1,1
15746           xj=xj_safe+xshift*boxxsize
15747           yj=yj_safe+yshift*boxysize
15748           zj=zj_safe+zshift*boxzsize
15749           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15750           if(dist_temp.lt.dist_init) then
15751             dist_init=dist_temp
15752             xj_temp=xj
15753             yj_temp=yj
15754             zj_temp=zj
15755             isubchap=1
15756           endif
15757        enddo
15758        enddo
15759        enddo
15760        if (isubchap.eq.1) then
15761 !C          print *,i,j
15762           xj=xj_temp-xmedi
15763           yj=yj_temp-ymedi
15764           zj=zj_temp-zmedi
15765        else
15766           xj=xj_safe-xmedi
15767           yj=yj_safe-ymedi
15768           zj=zj_safe-zmedi
15769        endif
15770
15771           rij=xj*xj+yj*yj+zj*zj
15772           rrmij=1.0D0/rij
15773           rij=dsqrt(rij)
15774           sss=sscale(rij/rpp(iteli,itelj))
15775             sss_ele_cut=sscale_ele(rij)
15776             sss_ele_grad=sscagrad_ele(rij)
15777             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15778             if (sss_ele_cut.le.0.0) cycle
15779           if (sss.gt.0.0d0) then
15780             rmij=1.0D0/rij
15781             r3ij=rrmij*rmij
15782             r6ij=r3ij*r3ij
15783             ev1=aaa*r6ij*r6ij
15784 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15785             if (j.eq.i+2) ev1=scal_el*ev1
15786             ev2=bbb*r6ij
15787             evdwij=ev1+ev2
15788             if (energy_dec) then
15789               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15790             endif
15791             evdw1=evdw1+evdwij*sss*sss_ele_cut
15792 !
15793 ! Calculate contributions to the Cartesian gradient.
15794 !
15795             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15796 !            ggg(1)=facvdw*xj
15797 !            ggg(2)=facvdw*yj
15798 !            ggg(3)=facvdw*zj
15799           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15800           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15801           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15802           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15803           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15804           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15805
15806             do k=1,3
15807               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15808               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15809             enddo
15810           endif
15811         enddo ! j
15812       enddo   ! i
15813       return
15814       end subroutine evdwpp_short
15815 !-----------------------------------------------------------------------------
15816       subroutine escp_long(evdw2,evdw2_14)
15817 !
15818 ! This subroutine calculates the excluded-volume interaction energy between
15819 ! peptide-group centers and side chains and its gradient in virtual-bond and
15820 ! side-chain vectors.
15821 !
15822 !      implicit real*8 (a-h,o-z)
15823 !      include 'DIMENSIONS'
15824 !      include 'COMMON.GEO'
15825 !      include 'COMMON.VAR'
15826 !      include 'COMMON.LOCAL'
15827 !      include 'COMMON.CHAIN'
15828 !      include 'COMMON.DERIV'
15829 !      include 'COMMON.INTERACT'
15830 !      include 'COMMON.FFIELD'
15831 !      include 'COMMON.IOUNITS'
15832 !      include 'COMMON.CONTROL'
15833       real(kind=8),dimension(3) :: ggg
15834 !el local variables
15835       integer :: i,iint,j,k,iteli,itypj,subchap
15836       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15837       real(kind=8) :: evdw2,evdw2_14,evdwij
15838       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15839                     dist_temp, dist_init
15840
15841       evdw2=0.0D0
15842       evdw2_14=0.0d0
15843 !d    print '(a)','Enter ESCP'
15844 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15845       do i=iatscp_s,iatscp_e
15846         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15847         iteli=itel(i)
15848         xi=0.5D0*(c(1,i)+c(1,i+1))
15849         yi=0.5D0*(c(2,i)+c(2,i+1))
15850         zi=0.5D0*(c(3,i)+c(3,i+1))
15851           xi=mod(xi,boxxsize)
15852           if (xi.lt.0) xi=xi+boxxsize
15853           yi=mod(yi,boxysize)
15854           if (yi.lt.0) yi=yi+boxysize
15855           zi=mod(zi,boxzsize)
15856           if (zi.lt.0) zi=zi+boxzsize
15857
15858         do iint=1,nscp_gr(i)
15859
15860         do j=iscpstart(i,iint),iscpend(i,iint)
15861           itypj=itype(j,1)
15862           if (itypj.eq.ntyp1) cycle
15863 ! Uncomment following three lines for SC-p interactions
15864 !         xj=c(1,nres+j)-xi
15865 !         yj=c(2,nres+j)-yi
15866 !         zj=c(3,nres+j)-zi
15867 ! Uncomment following three lines for Ca-p interactions
15868           xj=c(1,j)
15869           yj=c(2,j)
15870           zj=c(3,j)
15871           xj=mod(xj,boxxsize)
15872           if (xj.lt.0) xj=xj+boxxsize
15873           yj=mod(yj,boxysize)
15874           if (yj.lt.0) yj=yj+boxysize
15875           zj=mod(zj,boxzsize)
15876           if (zj.lt.0) zj=zj+boxzsize
15877       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15878       xj_safe=xj
15879       yj_safe=yj
15880       zj_safe=zj
15881       subchap=0
15882       do xshift=-1,1
15883       do yshift=-1,1
15884       do zshift=-1,1
15885           xj=xj_safe+xshift*boxxsize
15886           yj=yj_safe+yshift*boxysize
15887           zj=zj_safe+zshift*boxzsize
15888           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15889           if(dist_temp.lt.dist_init) then
15890             dist_init=dist_temp
15891             xj_temp=xj
15892             yj_temp=yj
15893             zj_temp=zj
15894             subchap=1
15895           endif
15896        enddo
15897        enddo
15898        enddo
15899        if (subchap.eq.1) then
15900           xj=xj_temp-xi
15901           yj=yj_temp-yi
15902           zj=zj_temp-zi
15903        else
15904           xj=xj_safe-xi
15905           yj=yj_safe-yi
15906           zj=zj_safe-zi
15907        endif
15908           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15909
15910           rij=dsqrt(1.0d0/rrij)
15911             sss_ele_cut=sscale_ele(rij)
15912             sss_ele_grad=sscagrad_ele(rij)
15913 !            print *,sss_ele_cut,sss_ele_grad,&
15914 !            (rij),r_cut_ele,rlamb_ele
15915             if (sss_ele_cut.le.0.0) cycle
15916           sss=sscale((rij/rscp(itypj,iteli)))
15917           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15918           if (sss.lt.1.0d0) then
15919
15920             fac=rrij**expon2
15921             e1=fac*fac*aad(itypj,iteli)
15922             e2=fac*bad(itypj,iteli)
15923             if (iabs(j-i) .le. 2) then
15924               e1=scal14*e1
15925               e2=scal14*e2
15926               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15927             endif
15928             evdwij=e1+e2
15929             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15930             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15931                 'evdw2',i,j,sss,evdwij
15932 !
15933 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15934 !
15935             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15936             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15937             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15938             ggg(1)=xj*fac
15939             ggg(2)=yj*fac
15940             ggg(3)=zj*fac
15941 ! Uncomment following three lines for SC-p interactions
15942 !           do k=1,3
15943 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15944 !           enddo
15945 ! Uncomment following line for SC-p interactions
15946 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15947             do k=1,3
15948               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15949               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15950             enddo
15951           endif
15952         enddo
15953
15954         enddo ! iint
15955       enddo ! i
15956       do i=1,nct
15957         do j=1,3
15958           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15959           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15960           gradx_scp(j,i)=expon*gradx_scp(j,i)
15961         enddo
15962       enddo
15963 !******************************************************************************
15964 !
15965 !                              N O T E !!!
15966 !
15967 ! To save time the factor EXPON has been extracted from ALL components
15968 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15969 ! use!
15970 !
15971 !******************************************************************************
15972       return
15973       end subroutine escp_long
15974 !-----------------------------------------------------------------------------
15975       subroutine escp_short(evdw2,evdw2_14)
15976 !
15977 ! This subroutine calculates the excluded-volume interaction energy between
15978 ! peptide-group centers and side chains and its gradient in virtual-bond and
15979 ! side-chain vectors.
15980 !
15981 !      implicit real*8 (a-h,o-z)
15982 !      include 'DIMENSIONS'
15983 !      include 'COMMON.GEO'
15984 !      include 'COMMON.VAR'
15985 !      include 'COMMON.LOCAL'
15986 !      include 'COMMON.CHAIN'
15987 !      include 'COMMON.DERIV'
15988 !      include 'COMMON.INTERACT'
15989 !      include 'COMMON.FFIELD'
15990 !      include 'COMMON.IOUNITS'
15991 !      include 'COMMON.CONTROL'
15992       real(kind=8),dimension(3) :: ggg
15993 !el local variables
15994       integer :: i,iint,j,k,iteli,itypj,subchap
15995       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15996       real(kind=8) :: evdw2,evdw2_14,evdwij
15997       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15998                     dist_temp, dist_init
15999
16000       evdw2=0.0D0
16001       evdw2_14=0.0d0
16002 !d    print '(a)','Enter ESCP'
16003 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16004       do i=iatscp_s,iatscp_e
16005         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16006         iteli=itel(i)
16007         xi=0.5D0*(c(1,i)+c(1,i+1))
16008         yi=0.5D0*(c(2,i)+c(2,i+1))
16009         zi=0.5D0*(c(3,i)+c(3,i+1))
16010           xi=mod(xi,boxxsize)
16011           if (xi.lt.0) xi=xi+boxxsize
16012           yi=mod(yi,boxysize)
16013           if (yi.lt.0) yi=yi+boxysize
16014           zi=mod(zi,boxzsize)
16015           if (zi.lt.0) zi=zi+boxzsize
16016
16017         do iint=1,nscp_gr(i)
16018
16019         do j=iscpstart(i,iint),iscpend(i,iint)
16020           itypj=itype(j,1)
16021           if (itypj.eq.ntyp1) cycle
16022 ! Uncomment following three lines for SC-p interactions
16023 !         xj=c(1,nres+j)-xi
16024 !         yj=c(2,nres+j)-yi
16025 !         zj=c(3,nres+j)-zi
16026 ! Uncomment following three lines for Ca-p interactions
16027 !          xj=c(1,j)-xi
16028 !          yj=c(2,j)-yi
16029 !          zj=c(3,j)-zi
16030           xj=c(1,j)
16031           yj=c(2,j)
16032           zj=c(3,j)
16033           xj=mod(xj,boxxsize)
16034           if (xj.lt.0) xj=xj+boxxsize
16035           yj=mod(yj,boxysize)
16036           if (yj.lt.0) yj=yj+boxysize
16037           zj=mod(zj,boxzsize)
16038           if (zj.lt.0) zj=zj+boxzsize
16039       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16040       xj_safe=xj
16041       yj_safe=yj
16042       zj_safe=zj
16043       subchap=0
16044       do xshift=-1,1
16045       do yshift=-1,1
16046       do zshift=-1,1
16047           xj=xj_safe+xshift*boxxsize
16048           yj=yj_safe+yshift*boxysize
16049           zj=zj_safe+zshift*boxzsize
16050           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16051           if(dist_temp.lt.dist_init) then
16052             dist_init=dist_temp
16053             xj_temp=xj
16054             yj_temp=yj
16055             zj_temp=zj
16056             subchap=1
16057           endif
16058        enddo
16059        enddo
16060        enddo
16061        if (subchap.eq.1) then
16062           xj=xj_temp-xi
16063           yj=yj_temp-yi
16064           zj=zj_temp-zi
16065        else
16066           xj=xj_safe-xi
16067           yj=yj_safe-yi
16068           zj=zj_safe-zi
16069        endif
16070
16071           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16072           rij=dsqrt(1.0d0/rrij)
16073             sss_ele_cut=sscale_ele(rij)
16074             sss_ele_grad=sscagrad_ele(rij)
16075 !            print *,sss_ele_cut,sss_ele_grad,&
16076 !            (rij),r_cut_ele,rlamb_ele
16077             if (sss_ele_cut.le.0.0) cycle
16078           sss=sscale(rij/rscp(itypj,iteli))
16079           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16080           if (sss.gt.0.0d0) then
16081
16082             fac=rrij**expon2
16083             e1=fac*fac*aad(itypj,iteli)
16084             e2=fac*bad(itypj,iteli)
16085             if (iabs(j-i) .le. 2) then
16086               e1=scal14*e1
16087               e2=scal14*e2
16088               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16089             endif
16090             evdwij=e1+e2
16091             evdw2=evdw2+evdwij*sss*sss_ele_cut
16092             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16093                 'evdw2',i,j,sss,evdwij
16094 !
16095 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16096 !
16097             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16098             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16099             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16100
16101             ggg(1)=xj*fac
16102             ggg(2)=yj*fac
16103             ggg(3)=zj*fac
16104 ! Uncomment following three lines for SC-p interactions
16105 !           do k=1,3
16106 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16107 !           enddo
16108 ! Uncomment following line for SC-p interactions
16109 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16110             do k=1,3
16111               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16112               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16113             enddo
16114           endif
16115         enddo
16116
16117         enddo ! iint
16118       enddo ! i
16119       do i=1,nct
16120         do j=1,3
16121           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16122           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16123           gradx_scp(j,i)=expon*gradx_scp(j,i)
16124         enddo
16125       enddo
16126 !******************************************************************************
16127 !
16128 !                              N O T E !!!
16129 !
16130 ! To save time the factor EXPON has been extracted from ALL components
16131 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16132 ! use!
16133 !
16134 !******************************************************************************
16135       return
16136       end subroutine escp_short
16137 !-----------------------------------------------------------------------------
16138 ! energy_p_new-sep_barrier.F
16139 !-----------------------------------------------------------------------------
16140       subroutine sc_grad_scale(scalfac)
16141 !      implicit real*8 (a-h,o-z)
16142       use calc_data
16143 !      include 'DIMENSIONS'
16144 !      include 'COMMON.CHAIN'
16145 !      include 'COMMON.DERIV'
16146 !      include 'COMMON.CALC'
16147 !      include 'COMMON.IOUNITS'
16148       real(kind=8),dimension(3) :: dcosom1,dcosom2
16149       real(kind=8) :: scalfac
16150 !el local variables
16151 !      integer :: i,j,k,l
16152
16153       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16154       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16155       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16156            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16157 ! diagnostics only
16158 !      eom1=0.0d0
16159 !      eom2=0.0d0
16160 !      eom12=evdwij*eps1_om12
16161 ! end diagnostics
16162 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16163 !     &  " sigder",sigder
16164 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16165 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16166       do k=1,3
16167         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16168         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16169       enddo
16170       do k=1,3
16171         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16172          *sss_ele_cut
16173       enddo
16174 !      write (iout,*) "gg",(gg(k),k=1,3)
16175       do k=1,3
16176         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16177                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16178                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16179                  *sss_ele_cut
16180         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16181                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16182                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16183          *sss_ele_cut
16184 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16185 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16186 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16187 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16188       enddo
16189 !
16190 ! Calculate the components of the gradient in DC and X
16191 !
16192       do l=1,3
16193         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16194         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16195       enddo
16196       return
16197       end subroutine sc_grad_scale
16198 !-----------------------------------------------------------------------------
16199 ! energy_split-sep.F
16200 !-----------------------------------------------------------------------------
16201       subroutine etotal_long(energia)
16202 !
16203 ! Compute the long-range slow-varying contributions to the energy
16204 !
16205 !      implicit real*8 (a-h,o-z)
16206 !      include 'DIMENSIONS'
16207       use MD_data, only: totT,usampl,eq_time
16208 #ifndef ISNAN
16209       external proc_proc
16210 #ifdef WINPGI
16211 !MS$ATTRIBUTES C ::  proc_proc
16212 #endif
16213 #endif
16214 #ifdef MPI
16215       include "mpif.h"
16216       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16217 #endif
16218 !      include 'COMMON.SETUP'
16219 !      include 'COMMON.IOUNITS'
16220 !      include 'COMMON.FFIELD'
16221 !      include 'COMMON.DERIV'
16222 !      include 'COMMON.INTERACT'
16223 !      include 'COMMON.SBRIDGE'
16224 !      include 'COMMON.CHAIN'
16225 !      include 'COMMON.VAR'
16226 !      include 'COMMON.LOCAL'
16227 !      include 'COMMON.MD'
16228       real(kind=8),dimension(0:n_ene) :: energia
16229 !el local variables
16230       integer :: i,n_corr,n_corr1,ierror,ierr
16231       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16232                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16233                   ecorr,ecorr5,ecorr6,eturn6,time00
16234 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16235 !elwrite(iout,*)"in etotal long"
16236
16237       if (modecalc.eq.12.or.modecalc.eq.14) then
16238 #ifdef MPI
16239 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16240 #else
16241         call int_from_cart1(.false.)
16242 #endif
16243       endif
16244 !elwrite(iout,*)"in etotal long"
16245
16246 #ifdef MPI
16247 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16248 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16249       call flush(iout)
16250       if (nfgtasks.gt.1) then
16251         time00=MPI_Wtime()
16252 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16253         if (fg_rank.eq.0) then
16254           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16255 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16256 !          call flush(iout)
16257 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16258 ! FG slaves as WEIGHTS array.
16259           weights_(1)=wsc
16260           weights_(2)=wscp
16261           weights_(3)=welec
16262           weights_(4)=wcorr
16263           weights_(5)=wcorr5
16264           weights_(6)=wcorr6
16265           weights_(7)=wel_loc
16266           weights_(8)=wturn3
16267           weights_(9)=wturn4
16268           weights_(10)=wturn6
16269           weights_(11)=wang
16270           weights_(12)=wscloc
16271           weights_(13)=wtor
16272           weights_(14)=wtor_d
16273           weights_(15)=wstrain
16274           weights_(16)=wvdwpp
16275           weights_(17)=wbond
16276           weights_(18)=scal14
16277           weights_(21)=wsccor
16278 ! FG Master broadcasts the WEIGHTS_ array
16279           call MPI_Bcast(weights_(1),n_ene,&
16280               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16281         else
16282 ! FG slaves receive the WEIGHTS array
16283           call MPI_Bcast(weights(1),n_ene,&
16284               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16285           wsc=weights(1)
16286           wscp=weights(2)
16287           welec=weights(3)
16288           wcorr=weights(4)
16289           wcorr5=weights(5)
16290           wcorr6=weights(6)
16291           wel_loc=weights(7)
16292           wturn3=weights(8)
16293           wturn4=weights(9)
16294           wturn6=weights(10)
16295           wang=weights(11)
16296           wscloc=weights(12)
16297           wtor=weights(13)
16298           wtor_d=weights(14)
16299           wstrain=weights(15)
16300           wvdwpp=weights(16)
16301           wbond=weights(17)
16302           scal14=weights(18)
16303           wsccor=weights(21)
16304         endif
16305         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16306           king,FG_COMM,IERR)
16307          time_Bcast=time_Bcast+MPI_Wtime()-time00
16308          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16309 !        call chainbuild_cart
16310 !        call int_from_cart1(.false.)
16311       endif
16312 !      write (iout,*) 'Processor',myrank,
16313 !     &  ' calling etotal_short ipot=',ipot
16314 !      call flush(iout)
16315 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16316 #endif
16317 !d    print *,'nnt=',nnt,' nct=',nct
16318 !
16319 !elwrite(iout,*)"in etotal long"
16320 ! Compute the side-chain and electrostatic interaction energy
16321 !
16322       goto (101,102,103,104,105,106) ipot
16323 ! Lennard-Jones potential.
16324   101 call elj_long(evdw)
16325 !d    print '(a)','Exit ELJ'
16326       goto 107
16327 ! Lennard-Jones-Kihara potential (shifted).
16328   102 call eljk_long(evdw)
16329       goto 107
16330 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16331   103 call ebp_long(evdw)
16332       goto 107
16333 ! Gay-Berne potential (shifted LJ, angular dependence).
16334   104 call egb_long(evdw)
16335       goto 107
16336 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16337   105 call egbv_long(evdw)
16338       goto 107
16339 ! Soft-sphere potential
16340   106 call e_softsphere(evdw)
16341 !
16342 ! Calculate electrostatic (H-bonding) energy of the main chain.
16343 !
16344   107 continue
16345       call vec_and_deriv
16346       if (ipot.lt.6) then
16347 #ifdef SPLITELE
16348          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16349              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16350              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16351              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16352 #else
16353          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16354              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16355              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16356              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16357 #endif
16358            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16359          else
16360             ees=0
16361             evdw1=0
16362             eel_loc=0
16363             eello_turn3=0
16364             eello_turn4=0
16365          endif
16366       else
16367 !        write (iout,*) "Soft-spheer ELEC potential"
16368         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16369          eello_turn4)
16370       endif
16371 !
16372 ! Calculate excluded-volume interaction energy between peptide groups
16373 ! and side chains.
16374 !
16375       if (ipot.lt.6) then
16376        if(wscp.gt.0d0) then
16377         call escp_long(evdw2,evdw2_14)
16378        else
16379         evdw2=0
16380         evdw2_14=0
16381        endif
16382       else
16383         call escp_soft_sphere(evdw2,evdw2_14)
16384       endif
16385 !
16386 ! 12/1/95 Multi-body terms
16387 !
16388       n_corr=0
16389       n_corr1=0
16390       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16391           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16392          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16393 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16394 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16395       else
16396          ecorr=0.0d0
16397          ecorr5=0.0d0
16398          ecorr6=0.0d0
16399          eturn6=0.0d0
16400       endif
16401       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16402          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16403       endif
16404 !
16405 ! If performing constraint dynamics, call the constraint energy
16406 !  after the equilibration time
16407       if(usampl.and.totT.gt.eq_time) then
16408          call EconstrQ
16409          call Econstr_back
16410       else
16411          Uconst=0.0d0
16412          Uconst_back=0.0d0
16413       endif
16414 !
16415 ! Sum the energies
16416 !
16417       do i=1,n_ene
16418         energia(i)=0.0d0
16419       enddo
16420       energia(1)=evdw
16421 #ifdef SCP14
16422       energia(2)=evdw2-evdw2_14
16423       energia(18)=evdw2_14
16424 #else
16425       energia(2)=evdw2
16426       energia(18)=0.0d0
16427 #endif
16428 #ifdef SPLITELE
16429       energia(3)=ees
16430       energia(16)=evdw1
16431 #else
16432       energia(3)=ees+evdw1
16433       energia(16)=0.0d0
16434 #endif
16435       energia(4)=ecorr
16436       energia(5)=ecorr5
16437       energia(6)=ecorr6
16438       energia(7)=eel_loc
16439       energia(8)=eello_turn3
16440       energia(9)=eello_turn4
16441       energia(10)=eturn6
16442       energia(20)=Uconst+Uconst_back
16443       call sum_energy(energia,.true.)
16444 !      write (iout,*) "Exit ETOTAL_LONG"
16445       call flush(iout)
16446       return
16447       end subroutine etotal_long
16448 !-----------------------------------------------------------------------------
16449       subroutine etotal_short(energia)
16450 !
16451 ! Compute the short-range fast-varying contributions to the energy
16452 !
16453 !      implicit real*8 (a-h,o-z)
16454 !      include 'DIMENSIONS'
16455 #ifndef ISNAN
16456       external proc_proc
16457 #ifdef WINPGI
16458 !MS$ATTRIBUTES C ::  proc_proc
16459 #endif
16460 #endif
16461 #ifdef MPI
16462       include "mpif.h"
16463       integer :: ierror,ierr
16464       real(kind=8),dimension(n_ene) :: weights_
16465       real(kind=8) :: time00
16466 #endif
16467 !      include 'COMMON.SETUP'
16468 !      include 'COMMON.IOUNITS'
16469 !      include 'COMMON.FFIELD'
16470 !      include 'COMMON.DERIV'
16471 !      include 'COMMON.INTERACT'
16472 !      include 'COMMON.SBRIDGE'
16473 !      include 'COMMON.CHAIN'
16474 !      include 'COMMON.VAR'
16475 !      include 'COMMON.LOCAL'
16476       real(kind=8),dimension(0:n_ene) :: energia
16477 !el local variables
16478       integer :: i,nres6
16479       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16480       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16481       nres6=6*nres
16482
16483 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16484 !      call flush(iout)
16485       if (modecalc.eq.12.or.modecalc.eq.14) then
16486 #ifdef MPI
16487         if (fg_rank.eq.0) call int_from_cart1(.false.)
16488 #else
16489         call int_from_cart1(.false.)
16490 #endif
16491       endif
16492 #ifdef MPI
16493 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16494 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16495 !      call flush(iout)
16496       if (nfgtasks.gt.1) then
16497         time00=MPI_Wtime()
16498 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16499         if (fg_rank.eq.0) then
16500           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16501 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16502 !          call flush(iout)
16503 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16504 ! FG slaves as WEIGHTS array.
16505           weights_(1)=wsc
16506           weights_(2)=wscp
16507           weights_(3)=welec
16508           weights_(4)=wcorr
16509           weights_(5)=wcorr5
16510           weights_(6)=wcorr6
16511           weights_(7)=wel_loc
16512           weights_(8)=wturn3
16513           weights_(9)=wturn4
16514           weights_(10)=wturn6
16515           weights_(11)=wang
16516           weights_(12)=wscloc
16517           weights_(13)=wtor
16518           weights_(14)=wtor_d
16519           weights_(15)=wstrain
16520           weights_(16)=wvdwpp
16521           weights_(17)=wbond
16522           weights_(18)=scal14
16523           weights_(21)=wsccor
16524 ! FG Master broadcasts the WEIGHTS_ array
16525           call MPI_Bcast(weights_(1),n_ene,&
16526               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16527         else
16528 ! FG slaves receive the WEIGHTS array
16529           call MPI_Bcast(weights(1),n_ene,&
16530               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16531           wsc=weights(1)
16532           wscp=weights(2)
16533           welec=weights(3)
16534           wcorr=weights(4)
16535           wcorr5=weights(5)
16536           wcorr6=weights(6)
16537           wel_loc=weights(7)
16538           wturn3=weights(8)
16539           wturn4=weights(9)
16540           wturn6=weights(10)
16541           wang=weights(11)
16542           wscloc=weights(12)
16543           wtor=weights(13)
16544           wtor_d=weights(14)
16545           wstrain=weights(15)
16546           wvdwpp=weights(16)
16547           wbond=weights(17)
16548           scal14=weights(18)
16549           wsccor=weights(21)
16550         endif
16551 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16552         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16553           king,FG_COMM,IERR)
16554 !        write (iout,*) "Processor",myrank," BROADCAST c"
16555         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16556           king,FG_COMM,IERR)
16557 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16558         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16559           king,FG_COMM,IERR)
16560 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16561         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16562           king,FG_COMM,IERR)
16563 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16564         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16565           king,FG_COMM,IERR)
16566 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16567         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16568           king,FG_COMM,IERR)
16569 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16570         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16571           king,FG_COMM,IERR)
16572 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16573         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16574           king,FG_COMM,IERR)
16575 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16576         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16577           king,FG_COMM,IERR)
16578          time_Bcast=time_Bcast+MPI_Wtime()-time00
16579 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16580       endif
16581 !      write (iout,*) 'Processor',myrank,
16582 !     &  ' calling etotal_short ipot=',ipot
16583 !      call flush(iout)
16584 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16585 #endif
16586 !      call int_from_cart1(.false.)
16587 !
16588 ! Compute the side-chain and electrostatic interaction energy
16589 !
16590       goto (101,102,103,104,105,106) ipot
16591 ! Lennard-Jones potential.
16592   101 call elj_short(evdw)
16593 !d    print '(a)','Exit ELJ'
16594       goto 107
16595 ! Lennard-Jones-Kihara potential (shifted).
16596   102 call eljk_short(evdw)
16597       goto 107
16598 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16599   103 call ebp_short(evdw)
16600       goto 107
16601 ! Gay-Berne potential (shifted LJ, angular dependence).
16602   104 call egb_short(evdw)
16603       goto 107
16604 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16605   105 call egbv_short(evdw)
16606       goto 107
16607 ! Soft-sphere potential - already dealt with in the long-range part
16608   106 evdw=0.0d0
16609 !  106 call e_softsphere_short(evdw)
16610 !
16611 ! Calculate electrostatic (H-bonding) energy of the main chain.
16612 !
16613   107 continue
16614 !
16615 ! Calculate the short-range part of Evdwpp
16616 !
16617       call evdwpp_short(evdw1)
16618 !
16619 ! Calculate the short-range part of ESCp
16620 !
16621       if (ipot.lt.6) then
16622         call escp_short(evdw2,evdw2_14)
16623       endif
16624 !
16625 ! Calculate the bond-stretching energy
16626 !
16627       call ebond(estr)
16628 !
16629 ! Calculate the disulfide-bridge and other energy and the contributions
16630 ! from other distance constraints.
16631       call edis(ehpb)
16632 !
16633 ! Calculate the virtual-bond-angle energy.
16634 !
16635 ! Calculate the SC local energy.
16636 !
16637       call vec_and_deriv
16638       call esc(escloc)
16639 !
16640       if (wang.gt.0d0) then
16641        if (tor_mode.eq.0) then
16642          call ebend(ebe)
16643        else
16644 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16645 !C energy function
16646          call ebend_kcc(ebe)
16647        endif
16648       else
16649         ebe=0.0d0
16650       endif
16651       ethetacnstr=0.0d0
16652       if (with_theta_constr) call etheta_constr(ethetacnstr)
16653
16654 !       write(iout,*) "in etotal afer ebe",ipot
16655
16656 !      print *,"Processor",myrank," computed UB"
16657 !
16658 ! Calculate the SC local energy.
16659 !
16660       call esc(escloc)
16661 !elwrite(iout,*) "in etotal afer esc",ipot
16662 !      print *,"Processor",myrank," computed USC"
16663 !
16664 ! Calculate the virtual-bond torsional energy.
16665 !
16666 !d    print *,'nterm=',nterm
16667 !      if (wtor.gt.0) then
16668 !       call etor(etors,edihcnstr)
16669 !      else
16670 !       etors=0
16671 !       edihcnstr=0
16672 !      endif
16673       if (wtor.gt.0.0d0) then
16674          if (tor_mode.eq.0) then
16675            call etor(etors)
16676          else
16677 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16678 !C energy function
16679            call etor_kcc(etors)
16680          endif
16681       else
16682         etors=0.0d0
16683       endif
16684       edihcnstr=0.0d0
16685       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16686
16687 ! Calculate the virtual-bond torsional energy.
16688 !
16689 !
16690 ! 6/23/01 Calculate double-torsional energy
16691 !
16692       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16693       call etor_d(etors_d)
16694       endif
16695 !
16696 ! 21/5/07 Calculate local sicdechain correlation energy
16697 !
16698       if (wsccor.gt.0.0d0) then
16699         call eback_sc_corr(esccor)
16700       else
16701         esccor=0.0d0
16702       endif
16703 !
16704 ! Put energy components into an array
16705 !
16706       do i=1,n_ene
16707         energia(i)=0.0d0
16708       enddo
16709       energia(1)=evdw
16710 #ifdef SCP14
16711       energia(2)=evdw2-evdw2_14
16712       energia(18)=evdw2_14
16713 #else
16714       energia(2)=evdw2
16715       energia(18)=0.0d0
16716 #endif
16717 #ifdef SPLITELE
16718       energia(16)=evdw1
16719 #else
16720       energia(3)=evdw1
16721 #endif
16722       energia(11)=ebe
16723       energia(12)=escloc
16724       energia(13)=etors
16725       energia(14)=etors_d
16726       energia(15)=ehpb
16727       energia(17)=estr
16728       energia(19)=edihcnstr
16729       energia(21)=esccor
16730 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16731       call flush(iout)
16732       call sum_energy(energia,.true.)
16733 !      write (iout,*) "Exit ETOTAL_SHORT"
16734       call flush(iout)
16735       return
16736       end subroutine etotal_short
16737 !-----------------------------------------------------------------------------
16738 ! gnmr1.f
16739 !-----------------------------------------------------------------------------
16740       real(kind=8) function gnmr1(y,ymin,ymax)
16741 !      implicit none
16742       real(kind=8) :: y,ymin,ymax
16743       real(kind=8) :: wykl=4.0d0
16744       if (y.lt.ymin) then
16745         gnmr1=(ymin-y)**wykl/wykl
16746       else if (y.gt.ymax) then
16747         gnmr1=(y-ymax)**wykl/wykl
16748       else
16749         gnmr1=0.0d0
16750       endif
16751       return
16752       end function gnmr1
16753 !-----------------------------------------------------------------------------
16754       real(kind=8) function gnmr1prim(y,ymin,ymax)
16755 !      implicit none
16756       real(kind=8) :: y,ymin,ymax
16757       real(kind=8) :: wykl=4.0d0
16758       if (y.lt.ymin) then
16759         gnmr1prim=-(ymin-y)**(wykl-1)
16760       else if (y.gt.ymax) then
16761         gnmr1prim=(y-ymax)**(wykl-1)
16762       else
16763         gnmr1prim=0.0d0
16764       endif
16765       return
16766       end function gnmr1prim
16767 !----------------------------------------------------------------------------
16768       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16769       real(kind=8) y,ymin,ymax,sigma
16770       real(kind=8) wykl /4.0d0/
16771       if (y.lt.ymin) then
16772         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16773       else if (y.gt.ymax) then
16774         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16775       else
16776         rlornmr1=0.0d0
16777       endif
16778       return
16779       end function rlornmr1
16780 !------------------------------------------------------------------------------
16781       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16782       real(kind=8) y,ymin,ymax,sigma
16783       real(kind=8) wykl /4.0d0/
16784       if (y.lt.ymin) then
16785         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16786         ((ymin-y)**wykl+sigma**wykl)**2
16787       else if (y.gt.ymax) then
16788         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16789         ((y-ymax)**wykl+sigma**wykl)**2
16790       else
16791         rlornmr1prim=0.0d0
16792       endif
16793       return
16794       end function rlornmr1prim
16795
16796       real(kind=8) function harmonic(y,ymax)
16797 !      implicit none
16798       real(kind=8) :: y,ymax
16799       real(kind=8) :: wykl=2.0d0
16800       harmonic=(y-ymax)**wykl
16801       return
16802       end function harmonic
16803 !-----------------------------------------------------------------------------
16804       real(kind=8) function harmonicprim(y,ymax)
16805       real(kind=8) :: y,ymin,ymax
16806       real(kind=8) :: wykl=2.0d0
16807       harmonicprim=(y-ymax)*wykl
16808       return
16809       end function harmonicprim
16810 !-----------------------------------------------------------------------------
16811 ! gradient_p.F
16812 !-----------------------------------------------------------------------------
16813       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16814
16815       use io_base, only:intout,briefout
16816 !      implicit real*8 (a-h,o-z)
16817 !      include 'DIMENSIONS'
16818 !      include 'COMMON.CHAIN'
16819 !      include 'COMMON.DERIV'
16820 !      include 'COMMON.VAR'
16821 !      include 'COMMON.INTERACT'
16822 !      include 'COMMON.FFIELD'
16823 !      include 'COMMON.MD'
16824 !      include 'COMMON.IOUNITS'
16825       real(kind=8),external :: ufparm
16826       integer :: uiparm(1)
16827       real(kind=8) :: urparm(1)
16828       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16829       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16830       integer :: n,nf,ind,ind1,i,k,j
16831 !
16832 ! This subroutine calculates total internal coordinate gradient.
16833 ! Depending on the number of function evaluations, either whole energy
16834 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16835 ! internal coordinates are reevaluated or only the cartesian-in-internal
16836 ! coordinate derivatives are evaluated. The subroutine was designed to work
16837 ! with SUMSL.
16838 !
16839 !
16840       icg=mod(nf,2)+1
16841
16842 !d      print *,'grad',nf,icg
16843       if (nf-nfl+1) 20,30,40
16844    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16845 !    write (iout,*) 'grad 20'
16846       if (nf.eq.0) return
16847       goto 40
16848    30 call var_to_geom(n,x)
16849       call chainbuild
16850 !    write (iout,*) 'grad 30'
16851 !
16852 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16853 !
16854    40 call cartder
16855 !     write (iout,*) 'grad 40'
16856 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16857 !
16858 ! Convert the Cartesian gradient into internal-coordinate gradient.
16859 !
16860       ind=0
16861       ind1=0
16862       do i=1,nres-2
16863       gthetai=0.0D0
16864       gphii=0.0D0
16865       do j=i+1,nres-1
16866           ind=ind+1
16867 !         ind=indmat(i,j)
16868 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16869         do k=1,3
16870             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16871           enddo
16872         do k=1,3
16873           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16874           enddo
16875         enddo
16876       do j=i+1,nres-1
16877           ind1=ind1+1
16878 !         ind1=indmat(i,j)
16879 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16880         do k=1,3
16881           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16882           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16883           enddo
16884         enddo
16885       if (i.gt.1) g(i-1)=gphii
16886       if (n.gt.nphi) g(nphi+i)=gthetai
16887       enddo
16888       if (n.le.nphi+ntheta) goto 10
16889       do i=2,nres-1
16890       if (itype(i,1).ne.10) then
16891           galphai=0.0D0
16892         gomegai=0.0D0
16893         do k=1,3
16894           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16895           enddo
16896         do k=1,3
16897           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16898           enddo
16899           g(ialph(i,1))=galphai
16900         g(ialph(i,1)+nside)=gomegai
16901         endif
16902       enddo
16903 !
16904 ! Add the components corresponding to local energy terms.
16905 !
16906    10 continue
16907       do i=1,nvar
16908 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16909         g(i)=g(i)+gloc(i,icg)
16910       enddo
16911 ! Uncomment following three lines for diagnostics.
16912 !d    call intout
16913 !elwrite(iout,*) "in gradient after calling intout"
16914 !d    call briefout(0,0.0d0)
16915 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16916       return
16917       end subroutine gradient
16918 !-----------------------------------------------------------------------------
16919       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16920
16921       use comm_chu
16922 !      implicit real*8 (a-h,o-z)
16923 !      include 'DIMENSIONS'
16924 !      include 'COMMON.DERIV'
16925 !      include 'COMMON.IOUNITS'
16926 !      include 'COMMON.GEO'
16927       integer :: n,nf
16928 !el      integer :: jjj
16929 !el      common /chuju/ jjj
16930       real(kind=8) :: energia(0:n_ene)
16931       integer :: uiparm(1)
16932       real(kind=8) :: urparm(1)
16933       real(kind=8) :: f
16934       real(kind=8),external :: ufparm
16935       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16936 !     if (jjj.gt.0) then
16937 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16938 !     endif
16939       nfl=nf
16940       icg=mod(nf,2)+1
16941 !d      print *,'func',nf,nfl,icg
16942       call var_to_geom(n,x)
16943       call zerograd
16944       call chainbuild
16945 !d    write (iout,*) 'ETOTAL called from FUNC'
16946       call etotal(energia)
16947       call sum_gradient
16948       f=energia(0)
16949 !     if (jjj.gt.0) then
16950 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16951 !       write (iout,*) 'f=',etot
16952 !       jjj=0
16953 !     endif
16954       return
16955       end subroutine func
16956 !-----------------------------------------------------------------------------
16957       subroutine cartgrad
16958 !      implicit real*8 (a-h,o-z)
16959 !      include 'DIMENSIONS'
16960       use energy_data
16961       use MD_data, only: totT,usampl,eq_time
16962 #ifdef MPI
16963       include 'mpif.h'
16964 #endif
16965 !      include 'COMMON.CHAIN'
16966 !      include 'COMMON.DERIV'
16967 !      include 'COMMON.VAR'
16968 !      include 'COMMON.INTERACT'
16969 !      include 'COMMON.FFIELD'
16970 !      include 'COMMON.MD'
16971 !      include 'COMMON.IOUNITS'
16972 !      include 'COMMON.TIME1'
16973 !
16974       integer :: i,j
16975
16976 ! This subrouting calculates total Cartesian coordinate gradient.
16977 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16978 !
16979 !#define DEBUG
16980 #ifdef TIMING
16981       time00=MPI_Wtime()
16982 #endif
16983       icg=1
16984       call sum_gradient
16985 #ifdef TIMING
16986 #endif
16987 !#define DEBUG
16988 !el      write (iout,*) "After sum_gradient"
16989 #ifdef DEBUG
16990 !el      write (iout,*) "After sum_gradient"
16991       do i=1,nres-1
16992         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16993         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16994       enddo
16995 #endif
16996 !#undef DEBUG
16997 ! If performing constraint dynamics, add the gradients of the constraint energy
16998       if(usampl.and.totT.gt.eq_time) then
16999          do i=1,nct
17000            do j=1,3
17001              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17002              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17003            enddo
17004          enddo
17005          do i=1,nres-3
17006            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17007          enddo
17008          do i=1,nres-2
17009            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17010          enddo
17011       endif
17012 !elwrite (iout,*) "After sum_gradient"
17013 #ifdef TIMING
17014       time01=MPI_Wtime()
17015 #endif
17016       call intcartderiv
17017 !elwrite (iout,*) "After sum_gradient"
17018 #ifdef TIMING
17019       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17020 #endif
17021 !     call checkintcartgrad
17022 !     write(iout,*) 'calling int_to_cart'
17023 !#define DEBUG
17024 #ifdef DEBUG
17025       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17026 #endif
17027       do i=0,nct
17028         do j=1,3
17029           gcart(j,i)=gradc(j,i,icg)
17030           gxcart(j,i)=gradx(j,i,icg)
17031 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17032         enddo
17033 #ifdef DEBUG
17034         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17035           (gxcart(j,i),j=1,3),gloc(i,icg)
17036 #endif
17037       enddo
17038 #ifdef TIMING
17039       time01=MPI_Wtime()
17040 #endif
17041 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17042       call int_to_cart
17043 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17044
17045 #ifdef TIMING
17046             time_inttocart=time_inttocart+MPI_Wtime()-time01
17047 #endif
17048 #ifdef DEBUG
17049             write (iout,*) "gcart and gxcart after int_to_cart"
17050             do i=0,nres-1
17051             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17052                 (gxcart(j,i),j=1,3)
17053             enddo
17054 #endif
17055 !#undef DEBUG
17056 #ifdef CARGRAD
17057 #ifdef DEBUG
17058             write (iout,*) "CARGRAD"
17059 #endif
17060             do i=nres,0,-1
17061             do j=1,3
17062               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17063       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17064             enddo
17065       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17066       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17067             enddo
17068       ! Correction: dummy residues
17069             if (nnt.gt.1) then
17070               do j=1,3
17071       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17072                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17073               enddo
17074             endif
17075             if (nct.lt.nres) then
17076               do j=1,3
17077       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17078                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17079               enddo
17080             endif
17081 #endif
17082 #ifdef TIMING
17083             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17084 #endif
17085 !#undef DEBUG
17086             return
17087             end subroutine cartgrad
17088       !-----------------------------------------------------------------------------
17089             subroutine zerograd
17090       !      implicit real*8 (a-h,o-z)
17091       !      include 'DIMENSIONS'
17092       !      include 'COMMON.DERIV'
17093       !      include 'COMMON.CHAIN'
17094       !      include 'COMMON.VAR'
17095       !      include 'COMMON.MD'
17096       !      include 'COMMON.SCCOR'
17097       !
17098       !el local variables
17099             integer :: i,j,intertyp,k
17100       ! Initialize Cartesian-coordinate gradient
17101       !
17102       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17103       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17104
17105       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17106       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17107       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17108       !      allocate(gradcorr_long(3,nres))
17109       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17110       !      allocate(gcorr6_turn_long(3,nres))
17111       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17112
17113       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17114
17115       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17116       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17117
17118       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17119       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17120
17121       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17122       !      allocate(gscloc(3,nres)) !(3,maxres)
17123       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17124
17125
17126
17127       !      common /deriv_scloc/
17128       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17129       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17130       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17131       !      common /mpgrad/
17132       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17133
17134
17135
17136       !          gradc(j,i,icg)=0.0d0
17137       !          gradx(j,i,icg)=0.0d0
17138
17139       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17140       !elwrite(iout,*) "icg",icg
17141             do i=-1,nres
17142             do j=1,3
17143               gvdwx(j,i)=0.0D0
17144               gradx_scp(j,i)=0.0D0
17145               gvdwc(j,i)=0.0D0
17146               gvdwc_scp(j,i)=0.0D0
17147               gvdwc_scpp(j,i)=0.0d0
17148               gelc(j,i)=0.0D0
17149               gelc_long(j,i)=0.0D0
17150               gradb(j,i)=0.0d0
17151               gradbx(j,i)=0.0d0
17152               gvdwpp(j,i)=0.0d0
17153               gel_loc(j,i)=0.0d0
17154               gel_loc_long(j,i)=0.0d0
17155               ghpbc(j,i)=0.0D0
17156               ghpbx(j,i)=0.0D0
17157               gcorr3_turn(j,i)=0.0d0
17158               gcorr4_turn(j,i)=0.0d0
17159               gradcorr(j,i)=0.0d0
17160               gradcorr_long(j,i)=0.0d0
17161               gradcorr5_long(j,i)=0.0d0
17162               gradcorr6_long(j,i)=0.0d0
17163               gcorr6_turn_long(j,i)=0.0d0
17164               gradcorr5(j,i)=0.0d0
17165               gradcorr6(j,i)=0.0d0
17166               gcorr6_turn(j,i)=0.0d0
17167               gsccorc(j,i)=0.0d0
17168               gsccorx(j,i)=0.0d0
17169               gradc(j,i,icg)=0.0d0
17170               gradx(j,i,icg)=0.0d0
17171               gscloc(j,i)=0.0d0
17172               gsclocx(j,i)=0.0d0
17173               gliptran(j,i)=0.0d0
17174               gliptranx(j,i)=0.0d0
17175               gliptranc(j,i)=0.0d0
17176               gshieldx(j,i)=0.0d0
17177               gshieldc(j,i)=0.0d0
17178               gshieldc_loc(j,i)=0.0d0
17179               gshieldx_ec(j,i)=0.0d0
17180               gshieldc_ec(j,i)=0.0d0
17181               gshieldc_loc_ec(j,i)=0.0d0
17182               gshieldx_t3(j,i)=0.0d0
17183               gshieldc_t3(j,i)=0.0d0
17184               gshieldc_loc_t3(j,i)=0.0d0
17185               gshieldx_t4(j,i)=0.0d0
17186               gshieldc_t4(j,i)=0.0d0
17187               gshieldc_loc_t4(j,i)=0.0d0
17188               gshieldx_ll(j,i)=0.0d0
17189               gshieldc_ll(j,i)=0.0d0
17190               gshieldc_loc_ll(j,i)=0.0d0
17191               gg_tube(j,i)=0.0d0
17192               gg_tube_sc(j,i)=0.0d0
17193               gradafm(j,i)=0.0d0
17194               gradb_nucl(j,i)=0.0d0
17195               gradbx_nucl(j,i)=0.0d0
17196               gvdwpp_nucl(j,i)=0.0d0
17197               gvdwpp(j,i)=0.0d0
17198               gelpp(j,i)=0.0d0
17199               gvdwpsb(j,i)=0.0d0
17200               gvdwpsb1(j,i)=0.0d0
17201               gvdwsbc(j,i)=0.0d0
17202               gvdwsbx(j,i)=0.0d0
17203               gelsbc(j,i)=0.0d0
17204               gradcorr_nucl(j,i)=0.0d0
17205               gradcorr3_nucl(j,i)=0.0d0
17206               gradxorr_nucl(j,i)=0.0d0
17207               gradxorr3_nucl(j,i)=0.0d0
17208               gelsbx(j,i)=0.0d0
17209               gsbloc(j,i)=0.0d0
17210               gsblocx(j,i)=0.0d0
17211               gradpepcat(j,i)=0.0d0
17212               gradpepcatx(j,i)=0.0d0
17213               gradcatcat(j,i)=0.0d0
17214               gvdwx_scbase(j,i)=0.0d0
17215               gvdwc_scbase(j,i)=0.0d0
17216               gvdwx_pepbase(j,i)=0.0d0
17217               gvdwc_pepbase(j,i)=0.0d0
17218               gvdwx_scpho(j,i)=0.0d0
17219               gvdwc_scpho(j,i)=0.0d0
17220               gvdwc_peppho(j,i)=0.0d0
17221             enddo
17222              enddo
17223             do i=0,nres
17224             do j=1,3
17225               do intertyp=1,3
17226                gloc_sc(intertyp,i,icg)=0.0d0
17227               enddo
17228             enddo
17229             enddo
17230             do i=1,nres
17231              do j=1,maxcontsshi
17232              shield_list(j,i)=0
17233             do k=1,3
17234       !C           print *,i,j,k
17235                grad_shield_side(k,j,i)=0.0d0
17236                grad_shield_loc(k,j,i)=0.0d0
17237              enddo
17238              enddo
17239              ishield_list(i)=0
17240             enddo
17241
17242       !
17243       ! Initialize the gradient of local energy terms.
17244       !
17245       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17246       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17247       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17248       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17249       !      allocate(gel_loc_turn3(nres))
17250       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17251       !      allocate(gsccor_loc(nres))      !(maxres)
17252
17253             do i=1,4*nres
17254             gloc(i,icg)=0.0D0
17255             enddo
17256             do i=1,nres
17257             gel_loc_loc(i)=0.0d0
17258             gcorr_loc(i)=0.0d0
17259             g_corr5_loc(i)=0.0d0
17260             g_corr6_loc(i)=0.0d0
17261             gel_loc_turn3(i)=0.0d0
17262             gel_loc_turn4(i)=0.0d0
17263             gel_loc_turn6(i)=0.0d0
17264             gsccor_loc(i)=0.0d0
17265             enddo
17266       ! initialize gcart and gxcart
17267       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17268             do i=0,nres
17269             do j=1,3
17270               gcart(j,i)=0.0d0
17271               gxcart(j,i)=0.0d0
17272             enddo
17273             enddo
17274             return
17275             end subroutine zerograd
17276       !-----------------------------------------------------------------------------
17277             real(kind=8) function fdum()
17278             fdum=0.0D0
17279             return
17280             end function fdum
17281       !-----------------------------------------------------------------------------
17282       ! intcartderiv.F
17283       !-----------------------------------------------------------------------------
17284             subroutine intcartderiv
17285       !      implicit real*8 (a-h,o-z)
17286       !      include 'DIMENSIONS'
17287 #ifdef MPI
17288             include 'mpif.h'
17289 #endif
17290       !      include 'COMMON.SETUP'
17291       !      include 'COMMON.CHAIN'
17292       !      include 'COMMON.VAR'
17293       !      include 'COMMON.GEO'
17294       !      include 'COMMON.INTERACT'
17295       !      include 'COMMON.DERIV'
17296       !      include 'COMMON.IOUNITS'
17297       !      include 'COMMON.LOCAL'
17298       !      include 'COMMON.SCCOR'
17299             real(kind=8) :: pi4,pi34
17300             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17301             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17302                       dcosomega,dsinomega !(3,3,maxres)
17303             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17304
17305             integer :: i,j,k
17306             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17307                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17308                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17309                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17310             integer :: nres2
17311             nres2=2*nres
17312
17313       !el from module energy-------------
17314       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17315       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17316       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17317
17318       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17319       !el      allocate(dsintau(3,3,3,0:nres2))
17320       !el      allocate(dtauangle(3,3,3,0:nres2))
17321       !el      allocate(domicron(3,2,2,0:nres2))
17322       !el      allocate(dcosomicron(3,2,2,0:nres2))
17323
17324
17325
17326 #if defined(MPI) && defined(PARINTDER)
17327             if (nfgtasks.gt.1 .and. me.eq.king) &
17328             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17329 #endif
17330             pi4 = 0.5d0*pipol
17331             pi34 = 3*pi4
17332
17333       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17334       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17335
17336       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17337             do i=1,nres
17338             do j=1,3
17339               dtheta(j,1,i)=0.0d0
17340               dtheta(j,2,i)=0.0d0
17341               dphi(j,1,i)=0.0d0
17342               dphi(j,2,i)=0.0d0
17343               dphi(j,3,i)=0.0d0
17344             enddo
17345             enddo
17346       ! Derivatives of theta's
17347 #if defined(MPI) && defined(PARINTDER)
17348       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17349             do i=max0(ithet_start-1,3),ithet_end
17350 #else
17351             do i=3,nres
17352 #endif
17353             cost=dcos(theta(i))
17354             sint=sqrt(1-cost*cost)
17355             do j=1,3
17356               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17357               vbld(i-1)
17358               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17359               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17360               vbld(i)
17361               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17362             enddo
17363             enddo
17364 #if defined(MPI) && defined(PARINTDER)
17365       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17366             do i=max0(ithet_start-1,3),ithet_end
17367 #else
17368             do i=3,nres
17369 #endif
17370             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
17371             cost1=dcos(omicron(1,i))
17372             sint1=sqrt(1-cost1*cost1)
17373             cost2=dcos(omicron(2,i))
17374             sint2=sqrt(1-cost2*cost2)
17375              do j=1,3
17376       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17377               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17378               cost1*dc_norm(j,i-2))/ &
17379               vbld(i-1)
17380               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17381               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17382               +cost1*(dc_norm(j,i-1+nres)))/ &
17383               vbld(i-1+nres)
17384               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17385       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17386       !C Looks messy but better than if in loop
17387               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17388               +cost2*dc_norm(j,i-1))/ &
17389               vbld(i)
17390               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17391               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17392                +cost2*(-dc_norm(j,i-1+nres)))/ &
17393               vbld(i-1+nres)
17394       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17395               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17396             enddo
17397              endif
17398             enddo
17399       !elwrite(iout,*) "after vbld write"
17400       ! Derivatives of phi:
17401       ! If phi is 0 or 180 degrees, then the formulas
17402       ! have to be derived by power series expansion of the
17403       ! conventional formulas around 0 and 180.
17404 #ifdef PARINTDER
17405             do i=iphi1_start,iphi1_end
17406 #else
17407             do i=4,nres
17408 #endif
17409       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17410       ! the conventional case
17411             sint=dsin(theta(i))
17412             sint1=dsin(theta(i-1))
17413             sing=dsin(phi(i))
17414             cost=dcos(theta(i))
17415             cost1=dcos(theta(i-1))
17416             cosg=dcos(phi(i))
17417             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17418             fac0=1.0d0/(sint1*sint)
17419             fac1=cost*fac0
17420             fac2=cost1*fac0
17421             fac3=cosg*cost1/(sint1*sint1)
17422             fac4=cosg*cost/(sint*sint)
17423       !    Obtaining the gamma derivatives from sine derivative
17424              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17425                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17426                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17427              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17428              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17429              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17430              do j=1,3
17431                 ctgt=cost/sint
17432                 ctgt1=cost1/sint1
17433                 cosg_inv=1.0d0/cosg
17434                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17435                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17436                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17437                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17438                 dsinphi(j,2,i)= &
17439                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17440                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17441                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17442                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17443                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17444       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17445                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17446                 endif
17447       ! Bug fixed 3/24/05 (AL)
17448              enddo
17449       !   Obtaining the gamma derivatives from cosine derivative
17450             else
17451                do j=1,3
17452                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17453                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17454                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17455                dc_norm(j,i-3))/vbld(i-2)
17456                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17457                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17458                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17459                dcostheta(j,1,i)
17460                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17461                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17462                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17463                dc_norm(j,i-1))/vbld(i)
17464                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17465 !#define DEBUG
17466 #ifdef DEBUG
17467                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17468 #endif
17469 !#undef DEBUG
17470                endif
17471              enddo
17472             endif
17473             enddo
17474       !alculate derivative of Tauangle
17475 #ifdef PARINTDER
17476             do i=itau_start,itau_end
17477 #else
17478             do i=3,nres
17479       !elwrite(iout,*) " vecpr",i,nres
17480 #endif
17481              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17482       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17483       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17484       !c dtauangle(j,intertyp,dervityp,residue number)
17485       !c INTERTYP=1 SC...Ca...Ca..Ca
17486       ! the conventional case
17487             sint=dsin(theta(i))
17488             sint1=dsin(omicron(2,i-1))
17489             sing=dsin(tauangle(1,i))
17490             cost=dcos(theta(i))
17491             cost1=dcos(omicron(2,i-1))
17492             cosg=dcos(tauangle(1,i))
17493       !elwrite(iout,*) " vecpr5",i,nres
17494             do j=1,3
17495       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17496       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17497             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17498       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17499             enddo
17500             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17501             fac0=1.0d0/(sint1*sint)
17502             fac1=cost*fac0
17503             fac2=cost1*fac0
17504             fac3=cosg*cost1/(sint1*sint1)
17505             fac4=cosg*cost/(sint*sint)
17506       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17507       !    Obtaining the gamma derivatives from sine derivative
17508              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17509                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17510                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17511              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17512              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17513              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17514             do j=1,3
17515                 ctgt=cost/sint
17516                 ctgt1=cost1/sint1
17517                 cosg_inv=1.0d0/cosg
17518                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17519              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17520              *vbld_inv(i-2+nres)
17521                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17522                 dsintau(j,1,2,i)= &
17523                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17524                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17525       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17526                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17527       ! Bug fixed 3/24/05 (AL)
17528                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17529                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17530       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17531                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17532              enddo
17533       !   Obtaining the gamma derivatives from cosine derivative
17534             else
17535                do j=1,3
17536                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17537                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17538                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17539                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17540                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17541                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17542                dcostheta(j,1,i)
17543                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17544                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17545                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17546                dc_norm(j,i-1))/vbld(i)
17547                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17548       !         write (iout,*) "else",i
17549              enddo
17550             endif
17551       !        do k=1,3
17552       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17553       !        enddo
17554             enddo
17555       !C Second case Ca...Ca...Ca...SC
17556 #ifdef PARINTDER
17557             do i=itau_start,itau_end
17558 #else
17559             do i=4,nres
17560 #endif
17561              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17562               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17563       ! the conventional case
17564             sint=dsin(omicron(1,i))
17565             sint1=dsin(theta(i-1))
17566             sing=dsin(tauangle(2,i))
17567             cost=dcos(omicron(1,i))
17568             cost1=dcos(theta(i-1))
17569             cosg=dcos(tauangle(2,i))
17570       !        do j=1,3
17571       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17572       !        enddo
17573             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17574             fac0=1.0d0/(sint1*sint)
17575             fac1=cost*fac0
17576             fac2=cost1*fac0
17577             fac3=cosg*cost1/(sint1*sint1)
17578             fac4=cosg*cost/(sint*sint)
17579       !    Obtaining the gamma derivatives from sine derivative
17580              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17581                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17582                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17583              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17584              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17585              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17586             do j=1,3
17587                 ctgt=cost/sint
17588                 ctgt1=cost1/sint1
17589                 cosg_inv=1.0d0/cosg
17590                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17591                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17592       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17593       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17594                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17595                 dsintau(j,2,2,i)= &
17596                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17597                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17598       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17599       !     & sing*ctgt*domicron(j,1,2,i),
17600       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17601                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17602       ! Bug fixed 3/24/05 (AL)
17603                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17604                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17605       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17606                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17607              enddo
17608       !   Obtaining the gamma derivatives from cosine derivative
17609             else
17610                do j=1,3
17611                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17612                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17613                dc_norm(j,i-3))/vbld(i-2)
17614                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17615                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17616                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17617                dcosomicron(j,1,1,i)
17618                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17619                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17620                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17621                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17622                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17623       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17624              enddo
17625             endif
17626             enddo
17627
17628       !CC third case SC...Ca...Ca...SC
17629 #ifdef PARINTDER
17630
17631             do i=itau_start,itau_end
17632 #else
17633             do i=3,nres
17634 #endif
17635       ! the conventional case
17636             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17637             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17638             sint=dsin(omicron(1,i))
17639             sint1=dsin(omicron(2,i-1))
17640             sing=dsin(tauangle(3,i))
17641             cost=dcos(omicron(1,i))
17642             cost1=dcos(omicron(2,i-1))
17643             cosg=dcos(tauangle(3,i))
17644             do j=1,3
17645             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17646       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17647             enddo
17648             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17649             fac0=1.0d0/(sint1*sint)
17650             fac1=cost*fac0
17651             fac2=cost1*fac0
17652             fac3=cosg*cost1/(sint1*sint1)
17653             fac4=cosg*cost/(sint*sint)
17654       !    Obtaining the gamma derivatives from sine derivative
17655              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17656                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17657                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17658              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17659              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17660              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17661             do j=1,3
17662                 ctgt=cost/sint
17663                 ctgt1=cost1/sint1
17664                 cosg_inv=1.0d0/cosg
17665                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17666                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17667                   *vbld_inv(i-2+nres)
17668                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17669                 dsintau(j,3,2,i)= &
17670                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17671                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17672                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17673       ! Bug fixed 3/24/05 (AL)
17674                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17675                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17676                   *vbld_inv(i-1+nres)
17677       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17678                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17679              enddo
17680       !   Obtaining the gamma derivatives from cosine derivative
17681             else
17682                do j=1,3
17683                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17684                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17685                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17686                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17687                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17688                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17689                dcosomicron(j,1,1,i)
17690                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17691                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17692                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17693                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17694                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17695       !          write(iout,*) "else",i
17696              enddo
17697             endif
17698             enddo
17699
17700 #ifdef CRYST_SC
17701       !   Derivatives of side-chain angles alpha and omega
17702 #if defined(MPI) && defined(PARINTDER)
17703             do i=ibond_start,ibond_end
17704 #else
17705             do i=2,nres-1
17706 #endif
17707               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17708                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17709                  fac6=fac5/vbld(i)
17710                  fac7=fac5*fac5
17711                  fac8=fac5/vbld(i+1)
17712                  fac9=fac5/vbld(i+nres)
17713                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17714                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17715                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17716                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17717                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17718                  sina=sqrt(1-cosa*cosa)
17719                  sino=dsin(omeg(i))
17720       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17721                  do j=1,3
17722                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17723                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17724                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17725                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17726                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17727                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17728                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17729                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17730                   vbld(i+nres))
17731                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17732                 enddo
17733       ! obtaining the derivatives of omega from sines
17734                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17735                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17736                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17737                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17738                    dsin(theta(i+1)))
17739                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17740                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17741                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17742                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17743                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17744                    coso_inv=1.0d0/dcos(omeg(i))
17745                    do j=1,3
17746                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17747                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17748                    (sino*dc_norm(j,i-1))/vbld(i)
17749                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17750                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17751                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17752                    -sino*dc_norm(j,i)/vbld(i+1)
17753                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17754                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17755                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17756                    vbld(i+nres)
17757                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17758                   enddo
17759                else
17760       !   obtaining the derivatives of omega from cosines
17761                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17762                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17763                  fac12=fac10*sina
17764                  fac13=fac12*fac12
17765                  fac14=sina*sina
17766                  do j=1,3
17767                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17768                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17769                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17770                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17771                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17772                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17773                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17774                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17775                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17776                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17777                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17778                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17779                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17780                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17781                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17782                 enddo
17783               endif
17784              else
17785                do j=1,3
17786                  do k=1,3
17787                    dalpha(k,j,i)=0.0d0
17788                    domega(k,j,i)=0.0d0
17789                  enddo
17790                enddo
17791              endif
17792              enddo
17793 #endif
17794 #if defined(MPI) && defined(PARINTDER)
17795             if (nfgtasks.gt.1) then
17796 #ifdef DEBUG
17797       !d      write (iout,*) "Gather dtheta"
17798       !d      call flush(iout)
17799             write (iout,*) "dtheta before gather"
17800             do i=1,nres
17801             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17802             enddo
17803 #endif
17804             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17805             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17806             king,FG_COMM,IERROR)
17807 !#define DEBUG
17808 #ifdef DEBUG
17809       !d      write (iout,*) "Gather dphi"
17810       !d      call flush(iout)
17811             write (iout,*) "dphi before gather"
17812             do i=1,nres
17813             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17814             enddo
17815 #endif
17816 !#undef DEBUG
17817             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17818             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17819             king,FG_COMM,IERROR)
17820       !d      write (iout,*) "Gather dalpha"
17821       !d      call flush(iout)
17822 #ifdef CRYST_SC
17823             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17824             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17825             king,FG_COMM,IERROR)
17826       !d      write (iout,*) "Gather domega"
17827       !d      call flush(iout)
17828             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17829             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17830             king,FG_COMM,IERROR)
17831 #endif
17832             endif
17833 #endif
17834 !#define DEBUG
17835 #ifdef DEBUG
17836             write (iout,*) "dtheta after gather"
17837             do i=1,nres
17838             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17839             enddo
17840             write (iout,*) "dphi after gather"
17841             do i=1,nres
17842             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17843             enddo
17844             write (iout,*) "dalpha after gather"
17845             do i=1,nres
17846             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17847             enddo
17848             write (iout,*) "domega after gather"
17849             do i=1,nres
17850             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17851             enddo
17852 #endif
17853 !#undef DEBUG
17854             return
17855             end subroutine intcartderiv
17856       !-----------------------------------------------------------------------------
17857             subroutine checkintcartgrad
17858       !      implicit real*8 (a-h,o-z)
17859       !      include 'DIMENSIONS'
17860 #ifdef MPI
17861             include 'mpif.h'
17862 #endif
17863       !      include 'COMMON.CHAIN'
17864       !      include 'COMMON.VAR'
17865       !      include 'COMMON.GEO'
17866       !      include 'COMMON.INTERACT'
17867       !      include 'COMMON.DERIV'
17868       !      include 'COMMON.IOUNITS'
17869       !      include 'COMMON.SETUP'
17870             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17871             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17872             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17873             real(kind=8),dimension(3) :: dc_norm_s
17874             real(kind=8) :: aincr=1.0d-5
17875             integer :: i,j
17876             real(kind=8) :: dcji
17877             do i=1,nres
17878             phi_s(i)=phi(i)
17879             theta_s(i)=theta(i)
17880             alph_s(i)=alph(i)
17881             omeg_s(i)=omeg(i)
17882             enddo
17883       ! Check theta gradient
17884             write (iout,*) &
17885              "Analytical (upper) and numerical (lower) gradient of theta"
17886             write (iout,*)
17887             do i=3,nres
17888             do j=1,3
17889               dcji=dc(j,i-2)
17890               dc(j,i-2)=dcji+aincr
17891               call chainbuild_cart
17892               call int_from_cart1(.false.)
17893           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17894           dc(j,i-2)=dcji
17895           dcji=dc(j,i-1)
17896           dc(j,i-1)=dc(j,i-1)+aincr
17897           call chainbuild_cart
17898           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17899           dc(j,i-1)=dcji
17900         enddo
17901 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17902 !el          (dtheta(j,2,i),j=1,3)
17903 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17904 !el          (dthetanum(j,2,i),j=1,3)
17905 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17906 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17907 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17908 !el        write (iout,*)
17909       enddo
17910 ! Check gamma gradient
17911       write (iout,*) &
17912        "Analytical (upper) and numerical (lower) gradient of gamma"
17913       do i=4,nres
17914         do j=1,3
17915           dcji=dc(j,i-3)
17916           dc(j,i-3)=dcji+aincr
17917           call chainbuild_cart
17918           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17919               dc(j,i-3)=dcji
17920           dcji=dc(j,i-2)
17921           dc(j,i-2)=dcji+aincr
17922           call chainbuild_cart
17923           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17924           dc(j,i-2)=dcji
17925           dcji=dc(j,i-1)
17926           dc(j,i-1)=dc(j,i-1)+aincr
17927           call chainbuild_cart
17928           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17929           dc(j,i-1)=dcji
17930         enddo
17931 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17932 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17933 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17934 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17935 !el        write (iout,'(5x,3(3f10.5,5x))') &
17936 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17937 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17938 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17939 !el        write (iout,*)
17940       enddo
17941 ! Check alpha gradient
17942       write (iout,*) &
17943        "Analytical (upper) and numerical (lower) gradient of alpha"
17944       do i=2,nres-1
17945        if(itype(i,1).ne.10) then
17946                  do j=1,3
17947                   dcji=dc(j,i-1)
17948                    dc(j,i-1)=dcji+aincr
17949               call chainbuild_cart
17950               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17951                  /aincr
17952                   dc(j,i-1)=dcji
17953               dcji=dc(j,i)
17954               dc(j,i)=dcji+aincr
17955               call chainbuild_cart
17956               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17957                  /aincr
17958               dc(j,i)=dcji
17959               dcji=dc(j,i+nres)
17960               dc(j,i+nres)=dc(j,i+nres)+aincr
17961               call chainbuild_cart
17962               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17963                  /aincr
17964              dc(j,i+nres)=dcji
17965             enddo
17966           endif
17967 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17968 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17969 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17970 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17971 !el        write (iout,'(5x,3(3f10.5,5x))') &
17972 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17973 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17974 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17975 !el        write (iout,*)
17976       enddo
17977 !     Check omega gradient
17978       write (iout,*) &
17979        "Analytical (upper) and numerical (lower) gradient of omega"
17980       do i=2,nres-1
17981        if(itype(i,1).ne.10) then
17982                  do j=1,3
17983                   dcji=dc(j,i-1)
17984                    dc(j,i-1)=dcji+aincr
17985               call chainbuild_cart
17986               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17987                  /aincr
17988                   dc(j,i-1)=dcji
17989               dcji=dc(j,i)
17990               dc(j,i)=dcji+aincr
17991               call chainbuild_cart
17992               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17993                  /aincr
17994               dc(j,i)=dcji
17995               dcji=dc(j,i+nres)
17996               dc(j,i+nres)=dc(j,i+nres)+aincr
17997               call chainbuild_cart
17998               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17999                  /aincr
18000              dc(j,i+nres)=dcji
18001             enddo
18002           endif
18003 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18004 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18005 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18006 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18007 !el        write (iout,'(5x,3(3f10.5,5x))') &
18008 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18009 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18010 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18011 !el        write (iout,*)
18012       enddo
18013       return
18014       end subroutine checkintcartgrad
18015 !-----------------------------------------------------------------------------
18016 ! q_measure.F
18017 !-----------------------------------------------------------------------------
18018       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18019 !      implicit real*8 (a-h,o-z)
18020 !      include 'DIMENSIONS'
18021 !      include 'COMMON.IOUNITS'
18022 !      include 'COMMON.CHAIN'
18023 !      include 'COMMON.INTERACT'
18024 !      include 'COMMON.VAR'
18025       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18026       integer :: kkk,nsep=3
18027       real(kind=8) :: qm      !dist,
18028       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18029       logical :: lprn=.false.
18030       logical :: flag
18031 !      real(kind=8) :: sigm,x
18032
18033 !el      sigm(x)=0.25d0*x     ! local function
18034       qqmax=1.0d10
18035       do kkk=1,nperm
18036       qq = 0.0d0
18037       nl=0
18038        if(flag) then
18039         do il=seg1+nsep,seg2
18040           do jl=seg1,il-nsep
18041             nl=nl+1
18042             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18043                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18044                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18045             dij=dist(il,jl)
18046             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18047             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18048               nl=nl+1
18049               d0ijCM=dsqrt( &
18050                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18051                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18052                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18053               dijCM=dist(il+nres,jl+nres)
18054               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18055             endif
18056             qq = qq+qqij+qqijCM
18057           enddo
18058         enddo
18059         qq = qq/nl
18060       else
18061       do il=seg1,seg2
18062         if((seg3-il).lt.3) then
18063              secseg=il+3
18064         else
18065              secseg=seg3
18066         endif
18067           do jl=secseg,seg4
18068             nl=nl+1
18069             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18070                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18071                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18072             dij=dist(il,jl)
18073             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18074             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18075               nl=nl+1
18076               d0ijCM=dsqrt( &
18077                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18078                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18079                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18080               dijCM=dist(il+nres,jl+nres)
18081               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18082             endif
18083             qq = qq+qqij+qqijCM
18084           enddo
18085         enddo
18086       qq = qq/nl
18087       endif
18088       if (qqmax.le.qq) qqmax=qq
18089       enddo
18090       qwolynes=1.0d0-qqmax
18091       return
18092       end function qwolynes
18093 !-----------------------------------------------------------------------------
18094       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18095 !      implicit real*8 (a-h,o-z)
18096 !      include 'DIMENSIONS'
18097 !      include 'COMMON.IOUNITS'
18098 !      include 'COMMON.CHAIN'
18099 !      include 'COMMON.INTERACT'
18100 !      include 'COMMON.VAR'
18101 !      include 'COMMON.MD'
18102       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18103       integer :: nsep=3, kkk
18104 !el      real(kind=8) :: dist
18105       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18106       logical :: lprn=.false.
18107       logical :: flag
18108       real(kind=8) :: sim,dd0,fac,ddqij
18109 !el      sigm(x)=0.25d0*x           ! local function
18110       do kkk=1,nperm
18111       do i=0,nres
18112         do j=1,3
18113           dqwol(j,i)=0.0d0
18114           dxqwol(j,i)=0.0d0
18115         enddo
18116       enddo
18117       nl=0
18118        if(flag) then
18119         do il=seg1+nsep,seg2
18120           do jl=seg1,il-nsep
18121             nl=nl+1
18122             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18123                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18124                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18125             dij=dist(il,jl)
18126             sim = 1.0d0/sigm(d0ij)
18127             sim = sim*sim
18128             dd0 = dij-d0ij
18129             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18130           do k=1,3
18131               ddqij = (c(k,il)-c(k,jl))*fac
18132               dqwol(k,il)=dqwol(k,il)+ddqij
18133               dqwol(k,jl)=dqwol(k,jl)-ddqij
18134             enddo
18135
18136             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18137               nl=nl+1
18138               d0ijCM=dsqrt( &
18139                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18140                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18141                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18142               dijCM=dist(il+nres,jl+nres)
18143               sim = 1.0d0/sigm(d0ijCM)
18144               sim = sim*sim
18145               dd0=dijCM-d0ijCM
18146               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18147               do k=1,3
18148                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18149                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18150                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18151               enddo
18152             endif
18153           enddo
18154         enddo
18155        else
18156         do il=seg1,seg2
18157         if((seg3-il).lt.3) then
18158              secseg=il+3
18159         else
18160              secseg=seg3
18161         endif
18162           do jl=secseg,seg4
18163             nl=nl+1
18164             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18165                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18166                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18167             dij=dist(il,jl)
18168             sim = 1.0d0/sigm(d0ij)
18169             sim = sim*sim
18170             dd0 = dij-d0ij
18171             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18172             do k=1,3
18173               ddqij = (c(k,il)-c(k,jl))*fac
18174               dqwol(k,il)=dqwol(k,il)+ddqij
18175               dqwol(k,jl)=dqwol(k,jl)-ddqij
18176             enddo
18177             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18178               nl=nl+1
18179               d0ijCM=dsqrt( &
18180                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18181                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18182                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18183               dijCM=dist(il+nres,jl+nres)
18184               sim = 1.0d0/sigm(d0ijCM)
18185               sim=sim*sim
18186               dd0 = dijCM-d0ijCM
18187               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18188               do k=1,3
18189                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18190                dxqwol(k,il)=dxqwol(k,il)+ddqij
18191                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18192               enddo
18193             endif
18194           enddo
18195         enddo
18196       endif
18197       enddo
18198        do i=0,nres
18199          do j=1,3
18200            dqwol(j,i)=dqwol(j,i)/nl
18201            dxqwol(j,i)=dxqwol(j,i)/nl
18202          enddo
18203        enddo
18204       return
18205       end subroutine qwolynes_prim
18206 !-----------------------------------------------------------------------------
18207       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18208 !      implicit real*8 (a-h,o-z)
18209 !      include 'DIMENSIONS'
18210 !      include 'COMMON.IOUNITS'
18211 !      include 'COMMON.CHAIN'
18212 !      include 'COMMON.INTERACT'
18213 !      include 'COMMON.VAR'
18214       integer :: seg1,seg2,seg3,seg4
18215       logical :: flag
18216       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18217       real(kind=8),dimension(3,0:2*nres) :: cdummy
18218       real(kind=8) :: q1,q2
18219       real(kind=8) :: delta=1.0d-10
18220       integer :: i,j
18221
18222       do i=0,nres
18223         do j=1,3
18224           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18225           cdummy(j,i)=c(j,i)
18226           c(j,i)=c(j,i)+delta
18227           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18228           qwolan(j,i)=(q2-q1)/delta
18229           c(j,i)=cdummy(j,i)
18230         enddo
18231       enddo
18232       do i=0,nres
18233         do j=1,3
18234           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18235           cdummy(j,i+nres)=c(j,i+nres)
18236           c(j,i+nres)=c(j,i+nres)+delta
18237           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18238           qwolxan(j,i)=(q2-q1)/delta
18239           c(j,i+nres)=cdummy(j,i+nres)
18240         enddo
18241       enddo
18242 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18243 !      do i=0,nct
18244 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18245 !      enddo
18246 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18247 !      do i=0,nct
18248 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18249 !      enddo
18250       return
18251       end subroutine qwol_num
18252 !-----------------------------------------------------------------------------
18253       subroutine EconstrQ
18254 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18255 !      implicit real*8 (a-h,o-z)
18256 !      include 'DIMENSIONS'
18257 !      include 'COMMON.CONTROL'
18258 !      include 'COMMON.VAR'
18259 !      include 'COMMON.MD'
18260       use MD_data
18261 !#ifndef LANG0
18262 !      include 'COMMON.LANGEVIN'
18263 !#else
18264 !      include 'COMMON.LANGEVIN.lang0'
18265 !#endif
18266 !      include 'COMMON.CHAIN'
18267 !      include 'COMMON.DERIV'
18268 !      include 'COMMON.GEO'
18269 !      include 'COMMON.LOCAL'
18270 !      include 'COMMON.INTERACT'
18271 !      include 'COMMON.IOUNITS'
18272 !      include 'COMMON.NAMES'
18273 !      include 'COMMON.TIME1'
18274       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18275       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18276                    duconst,duxconst
18277       integer :: kstart,kend,lstart,lend,idummy
18278       real(kind=8) :: delta=1.0d-7
18279       integer :: i,j,k,ii
18280       do i=0,nres
18281          do j=1,3
18282             duconst(j,i)=0.0d0
18283             dudconst(j,i)=0.0d0
18284             duxconst(j,i)=0.0d0
18285             dudxconst(j,i)=0.0d0
18286          enddo
18287       enddo
18288       Uconst=0.0d0
18289       do i=1,nfrag
18290          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18291            idummy,idummy)
18292          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18293 ! Calculating the derivatives of Constraint energy with respect to Q
18294          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18295            qinfrag(i,iset))
18296 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18297 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18298 !         hmnum=(hm2-hm1)/delta
18299 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18300 !     &   qinfrag(i,iset))
18301 !         write(iout,*) "harmonicnum frag", hmnum
18302 ! Calculating the derivatives of Q with respect to cartesian coordinates
18303          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18304           idummy,idummy)
18305 !         write(iout,*) "dqwol "
18306 !         do ii=1,nres
18307 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18308 !         enddo
18309 !         write(iout,*) "dxqwol "
18310 !         do ii=1,nres
18311 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18312 !         enddo
18313 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18314 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18315 !     &  ,idummy,idummy)
18316 !  The gradients of Uconst in Cs
18317          do ii=0,nres
18318             do j=1,3
18319                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18320                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18321             enddo
18322          enddo
18323       enddo
18324       do i=1,npair
18325          kstart=ifrag(1,ipair(1,i,iset),iset)
18326          kend=ifrag(2,ipair(1,i,iset),iset)
18327          lstart=ifrag(1,ipair(2,i,iset),iset)
18328          lend=ifrag(2,ipair(2,i,iset),iset)
18329          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18330          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18331 !  Calculating dU/dQ
18332          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18333 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18334 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18335 !         hmnum=(hm2-hm1)/delta
18336 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18337 !     &   qinpair(i,iset))
18338 !         write(iout,*) "harmonicnum pair ", hmnum
18339 ! Calculating dQ/dXi
18340          call qwolynes_prim(kstart,kend,.false.,&
18341           lstart,lend)
18342 !         write(iout,*) "dqwol "
18343 !         do ii=1,nres
18344 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18345 !         enddo
18346 !         write(iout,*) "dxqwol "
18347 !         do ii=1,nres
18348 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18349 !        enddo
18350 ! Calculating numerical gradients
18351 !        call qwol_num(kstart,kend,.false.
18352 !     &  ,lstart,lend)
18353 ! The gradients of Uconst in Cs
18354          do ii=0,nres
18355             do j=1,3
18356                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18357                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18358             enddo
18359          enddo
18360       enddo
18361 !      write(iout,*) "Uconst inside subroutine ", Uconst
18362 ! Transforming the gradients from Cs to dCs for the backbone
18363       do i=0,nres
18364          do j=i+1,nres
18365            do k=1,3
18366              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18367            enddo
18368          enddo
18369       enddo
18370 !  Transforming the gradients from Cs to dCs for the side chains
18371       do i=1,nres
18372          do j=1,3
18373            dudxconst(j,i)=duxconst(j,i)
18374          enddo
18375       enddo
18376 !      write(iout,*) "dU/ddc backbone "
18377 !       do ii=0,nres
18378 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18379 !      enddo
18380 !      write(iout,*) "dU/ddX side chain "
18381 !      do ii=1,nres
18382 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18383 !      enddo
18384 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18385 !      call dEconstrQ_num
18386       return
18387       end subroutine EconstrQ
18388 !-----------------------------------------------------------------------------
18389       subroutine dEconstrQ_num
18390 ! Calculating numerical dUconst/ddc and dUconst/ddx
18391 !      implicit real*8 (a-h,o-z)
18392 !      include 'DIMENSIONS'
18393 !      include 'COMMON.CONTROL'
18394 !      include 'COMMON.VAR'
18395 !      include 'COMMON.MD'
18396       use MD_data
18397 !#ifndef LANG0
18398 !      include 'COMMON.LANGEVIN'
18399 !#else
18400 !      include 'COMMON.LANGEVIN.lang0'
18401 !#endif
18402 !      include 'COMMON.CHAIN'
18403 !      include 'COMMON.DERIV'
18404 !      include 'COMMON.GEO'
18405 !      include 'COMMON.LOCAL'
18406 !      include 'COMMON.INTERACT'
18407 !      include 'COMMON.IOUNITS'
18408 !      include 'COMMON.NAMES'
18409 !      include 'COMMON.TIME1'
18410       real(kind=8) :: uzap1,uzap2
18411       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18412       integer :: kstart,kend,lstart,lend,idummy
18413       real(kind=8) :: delta=1.0d-7
18414 !el local variables
18415       integer :: i,ii,j
18416 !     real(kind=8) ::
18417 !     For the backbone
18418       do i=0,nres-1
18419          do j=1,3
18420             dUcartan(j,i)=0.0d0
18421             cdummy(j,i)=dc(j,i)
18422             dc(j,i)=dc(j,i)+delta
18423             call chainbuild_cart
18424           uzap2=0.0d0
18425             do ii=1,nfrag
18426              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18427                 idummy,idummy)
18428                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18429                 qinfrag(ii,iset))
18430             enddo
18431             do ii=1,npair
18432                kstart=ifrag(1,ipair(1,ii,iset),iset)
18433                kend=ifrag(2,ipair(1,ii,iset),iset)
18434                lstart=ifrag(1,ipair(2,ii,iset),iset)
18435                lend=ifrag(2,ipair(2,ii,iset),iset)
18436                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18437                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18438                  qinpair(ii,iset))
18439             enddo
18440             dc(j,i)=cdummy(j,i)
18441             call chainbuild_cart
18442             uzap1=0.0d0
18443              do ii=1,nfrag
18444              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18445                 idummy,idummy)
18446                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18447                 qinfrag(ii,iset))
18448             enddo
18449             do ii=1,npair
18450                kstart=ifrag(1,ipair(1,ii,iset),iset)
18451                kend=ifrag(2,ipair(1,ii,iset),iset)
18452                lstart=ifrag(1,ipair(2,ii,iset),iset)
18453                lend=ifrag(2,ipair(2,ii,iset),iset)
18454                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18455                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18456                 qinpair(ii,iset))
18457             enddo
18458             ducartan(j,i)=(uzap2-uzap1)/(delta)
18459          enddo
18460       enddo
18461 ! Calculating numerical gradients for dU/ddx
18462       do i=0,nres-1
18463          duxcartan(j,i)=0.0d0
18464          do j=1,3
18465             cdummy(j,i)=dc(j,i+nres)
18466             dc(j,i+nres)=dc(j,i+nres)+delta
18467             call chainbuild_cart
18468           uzap2=0.0d0
18469             do ii=1,nfrag
18470              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18471                 idummy,idummy)
18472                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18473                 qinfrag(ii,iset))
18474             enddo
18475             do ii=1,npair
18476                kstart=ifrag(1,ipair(1,ii,iset),iset)
18477                kend=ifrag(2,ipair(1,ii,iset),iset)
18478                lstart=ifrag(1,ipair(2,ii,iset),iset)
18479                lend=ifrag(2,ipair(2,ii,iset),iset)
18480                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18481                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18482                 qinpair(ii,iset))
18483             enddo
18484             dc(j,i+nres)=cdummy(j,i)
18485             call chainbuild_cart
18486             uzap1=0.0d0
18487              do ii=1,nfrag
18488                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18489                 ifrag(2,ii,iset),.true.,idummy,idummy)
18490                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18491                 qinfrag(ii,iset))
18492             enddo
18493             do ii=1,npair
18494                kstart=ifrag(1,ipair(1,ii,iset),iset)
18495                kend=ifrag(2,ipair(1,ii,iset),iset)
18496                lstart=ifrag(1,ipair(2,ii,iset),iset)
18497                lend=ifrag(2,ipair(2,ii,iset),iset)
18498                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18499                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18500                 qinpair(ii,iset))
18501             enddo
18502             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18503          enddo
18504       enddo
18505       write(iout,*) "Numerical dUconst/ddc backbone "
18506       do ii=0,nres
18507         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18508       enddo
18509 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18510 !      do ii=1,nres
18511 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18512 !      enddo
18513       return
18514       end subroutine dEconstrQ_num
18515 !-----------------------------------------------------------------------------
18516 ! ssMD.F
18517 !-----------------------------------------------------------------------------
18518       subroutine check_energies
18519
18520 !      use random, only: ran_number
18521
18522 !      implicit none
18523 !     Includes
18524 !      include 'DIMENSIONS'
18525 !      include 'COMMON.CHAIN'
18526 !      include 'COMMON.VAR'
18527 !      include 'COMMON.IOUNITS'
18528 !      include 'COMMON.SBRIDGE'
18529 !      include 'COMMON.LOCAL'
18530 !      include 'COMMON.GEO'
18531
18532 !     External functions
18533 !EL      double precision ran_number
18534 !EL      external ran_number
18535
18536 !     Local variables
18537       integer :: i,j,k,l,lmax,p,pmax
18538       real(kind=8) :: rmin,rmax
18539       real(kind=8) :: eij
18540
18541       real(kind=8) :: d
18542       real(kind=8) :: wi,rij,tj,pj
18543 !      return
18544
18545       i=5
18546       j=14
18547
18548       d=dsc(1)
18549       rmin=2.0D0
18550       rmax=12.0D0
18551
18552       lmax=10000
18553       pmax=1
18554
18555       do k=1,3
18556         c(k,i)=0.0D0
18557         c(k,j)=0.0D0
18558         c(k,nres+i)=0.0D0
18559         c(k,nres+j)=0.0D0
18560       enddo
18561
18562       do l=1,lmax
18563
18564 !t        wi=ran_number(0.0D0,pi)
18565 !        wi=ran_number(0.0D0,pi/6.0D0)
18566 !        wi=0.0D0
18567 !t        tj=ran_number(0.0D0,pi)
18568 !t        pj=ran_number(0.0D0,pi)
18569 !        pj=ran_number(0.0D0,pi/6.0D0)
18570 !        pj=0.0D0
18571
18572         do p=1,pmax
18573 !t           rij=ran_number(rmin,rmax)
18574
18575            c(1,j)=d*sin(pj)*cos(tj)
18576            c(2,j)=d*sin(pj)*sin(tj)
18577            c(3,j)=d*cos(pj)
18578
18579            c(3,nres+i)=-rij
18580
18581            c(1,i)=d*sin(wi)
18582            c(3,i)=-rij-d*cos(wi)
18583
18584            do k=1,3
18585               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18586               dc_norm(k,nres+i)=dc(k,nres+i)/d
18587               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18588               dc_norm(k,nres+j)=dc(k,nres+j)/d
18589            enddo
18590
18591            call dyn_ssbond_ene(i,j,eij)
18592         enddo
18593       enddo
18594       call exit(1)
18595       return
18596       end subroutine check_energies
18597 !-----------------------------------------------------------------------------
18598       subroutine dyn_ssbond_ene(resi,resj,eij)
18599 !      implicit none
18600 !      Includes
18601       use calc_data
18602       use comm_sschecks
18603 !      include 'DIMENSIONS'
18604 !      include 'COMMON.SBRIDGE'
18605 !      include 'COMMON.CHAIN'
18606 !      include 'COMMON.DERIV'
18607 !      include 'COMMON.LOCAL'
18608 !      include 'COMMON.INTERACT'
18609 !      include 'COMMON.VAR'
18610 !      include 'COMMON.IOUNITS'
18611 !      include 'COMMON.CALC'
18612 #ifndef CLUST
18613 #ifndef WHAM
18614        use MD_data
18615 !      include 'COMMON.MD'
18616 !      use MD, only: totT,t_bath
18617 #endif
18618 #endif
18619 !     External functions
18620 !EL      double precision h_base
18621 !EL      external h_base
18622
18623 !     Input arguments
18624       integer :: resi,resj
18625
18626 !     Output arguments
18627       real(kind=8) :: eij
18628
18629 !     Local variables
18630       logical :: havebond
18631       integer itypi,itypj
18632       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18633       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18634       real(kind=8),dimension(3) :: dcosom1,dcosom2
18635       real(kind=8) :: ed
18636       real(kind=8) :: pom1,pom2
18637       real(kind=8) :: ljA,ljB,ljXs
18638       real(kind=8),dimension(1:3) :: d_ljB
18639       real(kind=8) :: ssA,ssB,ssC,ssXs
18640       real(kind=8) :: ssxm,ljxm,ssm,ljm
18641       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18642       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18643       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18644 !-------FIRST METHOD
18645       real(kind=8) :: xm
18646       real(kind=8),dimension(1:3) :: d_xm
18647 !-------END FIRST METHOD
18648 !-------SECOND METHOD
18649 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18650 !-------END SECOND METHOD
18651
18652 !-------TESTING CODE
18653 !el      logical :: checkstop,transgrad
18654 !el      common /sschecks/ checkstop,transgrad
18655
18656       integer :: icheck,nicheck,jcheck,njcheck
18657       real(kind=8),dimension(-1:1) :: echeck
18658       real(kind=8) :: deps,ssx0,ljx0
18659 !-------END TESTING CODE
18660
18661       eij=0.0d0
18662       i=resi
18663       j=resj
18664
18665 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18666 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18667
18668       itypi=itype(i,1)
18669       dxi=dc_norm(1,nres+i)
18670       dyi=dc_norm(2,nres+i)
18671       dzi=dc_norm(3,nres+i)
18672       dsci_inv=vbld_inv(i+nres)
18673
18674       itypj=itype(j,1)
18675       xj=c(1,nres+j)-c(1,nres+i)
18676       yj=c(2,nres+j)-c(2,nres+i)
18677       zj=c(3,nres+j)-c(3,nres+i)
18678       dxj=dc_norm(1,nres+j)
18679       dyj=dc_norm(2,nres+j)
18680       dzj=dc_norm(3,nres+j)
18681       dscj_inv=vbld_inv(j+nres)
18682
18683       chi1=chi(itypi,itypj)
18684       chi2=chi(itypj,itypi)
18685       chi12=chi1*chi2
18686       chip1=chip(itypi)
18687       chip2=chip(itypj)
18688       chip12=chip1*chip2
18689       alf1=alp(itypi)
18690       alf2=alp(itypj)
18691       alf12=0.5D0*(alf1+alf2)
18692
18693       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18694       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18695 !     The following are set in sc_angular
18696 !      erij(1)=xj*rij
18697 !      erij(2)=yj*rij
18698 !      erij(3)=zj*rij
18699 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18700 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18701 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18702       call sc_angular
18703       rij=1.0D0/rij  ! Reset this so it makes sense
18704
18705       sig0ij=sigma(itypi,itypj)
18706       sig=sig0ij*dsqrt(1.0D0/sigsq)
18707
18708       ljXs=sig-sig0ij
18709       ljA=eps1*eps2rt**2*eps3rt**2
18710       ljB=ljA*bb_aq(itypi,itypj)
18711       ljA=ljA*aa_aq(itypi,itypj)
18712       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18713
18714       ssXs=d0cm
18715       deltat1=1.0d0-om1
18716       deltat2=1.0d0+om2
18717       deltat12=om2-om1+2.0d0
18718       cosphi=om12-om1*om2
18719       ssA=akcm
18720       ssB=akct*deltat12
18721       ssC=ss_depth &
18722            +akth*(deltat1*deltat1+deltat2*deltat2) &
18723            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18724       ssxm=ssXs-0.5D0*ssB/ssA
18725
18726 !-------TESTING CODE
18727 !$$$c     Some extra output
18728 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18729 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18730 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18731 !$$$      if (ssx0.gt.0.0d0) then
18732 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18733 !$$$      else
18734 !$$$        ssx0=ssxm
18735 !$$$      endif
18736 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18737 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18738 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18739 !$$$      return
18740 !-------END TESTING CODE
18741
18742 !-------TESTING CODE
18743 !     Stop and plot energy and derivative as a function of distance
18744       if (checkstop) then
18745         ssm=ssC-0.25D0*ssB*ssB/ssA
18746         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18747         if (ssm.lt.ljm .and. &
18748              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18749           nicheck=1000
18750           njcheck=1
18751           deps=0.5d-7
18752         else
18753           checkstop=.false.
18754         endif
18755       endif
18756       if (.not.checkstop) then
18757         nicheck=0
18758         njcheck=-1
18759       endif
18760
18761       do icheck=0,nicheck
18762       do jcheck=-1,njcheck
18763       if (checkstop) rij=(ssxm-1.0d0)+ &
18764              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18765 !-------END TESTING CODE
18766
18767       if (rij.gt.ljxm) then
18768         havebond=.false.
18769         ljd=rij-ljXs
18770         fac=(1.0D0/ljd)**expon
18771         e1=fac*fac*aa_aq(itypi,itypj)
18772         e2=fac*bb_aq(itypi,itypj)
18773         eij=eps1*eps2rt*eps3rt*(e1+e2)
18774         eps2der=eij*eps3rt
18775         eps3der=eij*eps2rt
18776         eij=eij*eps2rt*eps3rt
18777
18778         sigder=-sig/sigsq
18779         e1=e1*eps1*eps2rt**2*eps3rt**2
18780         ed=-expon*(e1+eij)/ljd
18781         sigder=ed*sigder
18782         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18783         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18784         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18785              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18786       else if (rij.lt.ssxm) then
18787         havebond=.true.
18788         ssd=rij-ssXs
18789         eij=ssA*ssd*ssd+ssB*ssd+ssC
18790
18791         ed=2*akcm*ssd+akct*deltat12
18792         pom1=akct*ssd
18793         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18794         eom1=-2*akth*deltat1-pom1-om2*pom2
18795         eom2= 2*akth*deltat2+pom1-om1*pom2
18796         eom12=pom2
18797       else
18798         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18799
18800         d_ssxm(1)=0.5D0*akct/ssA
18801         d_ssxm(2)=-d_ssxm(1)
18802         d_ssxm(3)=0.0D0
18803
18804         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18805         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18806         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18807         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18808
18809 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18810         xm=0.5d0*(ssxm+ljxm)
18811         do k=1,3
18812           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18813         enddo
18814         if (rij.lt.xm) then
18815           havebond=.true.
18816           ssm=ssC-0.25D0*ssB*ssB/ssA
18817           d_ssm(1)=0.5D0*akct*ssB/ssA
18818           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18819           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18820           d_ssm(3)=omega
18821           f1=(rij-xm)/(ssxm-xm)
18822           f2=(rij-ssxm)/(xm-ssxm)
18823           h1=h_base(f1,hd1)
18824           h2=h_base(f2,hd2)
18825           eij=ssm*h1+Ht*h2
18826           delta_inv=1.0d0/(xm-ssxm)
18827           deltasq_inv=delta_inv*delta_inv
18828           fac=ssm*hd1-Ht*hd2
18829           fac1=deltasq_inv*fac*(xm-rij)
18830           fac2=deltasq_inv*fac*(rij-ssxm)
18831           ed=delta_inv*(Ht*hd2-ssm*hd1)
18832           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18833           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18834           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18835         else
18836           havebond=.false.
18837           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18838           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18839           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18840           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18841                alf12/eps3rt)
18842           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18843           f1=(rij-ljxm)/(xm-ljxm)
18844           f2=(rij-xm)/(ljxm-xm)
18845           h1=h_base(f1,hd1)
18846           h2=h_base(f2,hd2)
18847           eij=Ht*h1+ljm*h2
18848           delta_inv=1.0d0/(ljxm-xm)
18849           deltasq_inv=delta_inv*delta_inv
18850           fac=Ht*hd1-ljm*hd2
18851           fac1=deltasq_inv*fac*(ljxm-rij)
18852           fac2=deltasq_inv*fac*(rij-xm)
18853           ed=delta_inv*(ljm*hd2-Ht*hd1)
18854           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18855           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18856           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18857         endif
18858 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18859
18860 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18861 !$$$        ssd=rij-ssXs
18862 !$$$        ljd=rij-ljXs
18863 !$$$        fac1=rij-ljxm
18864 !$$$        fac2=rij-ssxm
18865 !$$$
18866 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18867 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18868 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18869 !$$$
18870 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18871 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18872 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18873 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18874 !$$$        d_ssm(3)=omega
18875 !$$$
18876 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18877 !$$$        do k=1,3
18878 !$$$          d_ljm(k)=ljm*d_ljB(k)
18879 !$$$        enddo
18880 !$$$        ljm=ljm*ljB
18881 !$$$
18882 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18883 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18884 !$$$        d_ss(2)=akct*ssd
18885 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18886 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18887 !$$$        d_ss(3)=omega
18888 !$$$
18889 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18890 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18891 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18892 !$$$        do k=1,3
18893 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18894 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18895 !$$$        enddo
18896 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18897 !$$$
18898 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18899 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18900 !$$$        h1=h_base(f1,hd1)
18901 !$$$        h2=h_base(f2,hd2)
18902 !$$$        eij=ss*h1+ljf*h2
18903 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18904 !$$$        deltasq_inv=delta_inv*delta_inv
18905 !$$$        fac=ljf*hd2-ss*hd1
18906 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18907 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18908 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18909 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18910 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18911 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18912 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18913 !$$$
18914 !$$$        havebond=.false.
18915 !$$$        if (ed.gt.0.0d0) havebond=.true.
18916 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18917
18918       endif
18919
18920       if (havebond) then
18921 !#ifndef CLUST
18922 !#ifndef WHAM
18923 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18924 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18925 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18926 !        endif
18927 !#endif
18928 !#endif
18929         dyn_ssbond_ij(i,j)=eij
18930       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18931         dyn_ssbond_ij(i,j)=1.0d300
18932 !#ifndef CLUST
18933 !#ifndef WHAM
18934 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18935 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18936 !#endif
18937 !#endif
18938       endif
18939
18940 !-------TESTING CODE
18941 !el      if (checkstop) then
18942         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18943              "CHECKSTOP",rij,eij,ed
18944         echeck(jcheck)=eij
18945 !el      endif
18946       enddo
18947       if (checkstop) then
18948         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18949       endif
18950       enddo
18951       if (checkstop) then
18952         transgrad=.true.
18953         checkstop=.false.
18954       endif
18955 !-------END TESTING CODE
18956
18957       do k=1,3
18958         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18959         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18960       enddo
18961       do k=1,3
18962         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18963       enddo
18964       do k=1,3
18965         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18966              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18967              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18968         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18969              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18970              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18971       enddo
18972 !grad      do k=i,j-1
18973 !grad        do l=1,3
18974 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18975 !grad        enddo
18976 !grad      enddo
18977
18978       do l=1,3
18979         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18980         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18981       enddo
18982
18983       return
18984       end subroutine dyn_ssbond_ene
18985 !--------------------------------------------------------------------------
18986          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18987 !      implicit none
18988 !      Includes
18989       use calc_data
18990       use comm_sschecks
18991 !      include 'DIMENSIONS'
18992 !      include 'COMMON.SBRIDGE'
18993 !      include 'COMMON.CHAIN'
18994 !      include 'COMMON.DERIV'
18995 !      include 'COMMON.LOCAL'
18996 !      include 'COMMON.INTERACT'
18997 !      include 'COMMON.VAR'
18998 !      include 'COMMON.IOUNITS'
18999 !      include 'COMMON.CALC'
19000 #ifndef CLUST
19001 #ifndef WHAM
19002        use MD_data
19003 !      include 'COMMON.MD'
19004 !      use MD, only: totT,t_bath
19005 #endif
19006 #endif
19007       double precision h_base
19008       external h_base
19009
19010 !c     Input arguments
19011       integer resi,resj,resk,m,itypi,itypj,itypk
19012
19013 !c     Output arguments
19014       double precision eij,eij1,eij2,eij3
19015
19016 !c     Local variables
19017       logical havebond
19018 !c      integer itypi,itypj,k,l
19019       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19020       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19021       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19022       double precision sig0ij,ljd,sig,fac,e1,e2
19023       double precision dcosom1(3),dcosom2(3),ed
19024       double precision pom1,pom2
19025       double precision ljA,ljB,ljXs
19026       double precision d_ljB(1:3)
19027       double precision ssA,ssB,ssC,ssXs
19028       double precision ssxm,ljxm,ssm,ljm
19029       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19030       eij=0.0
19031       if (dtriss.eq.0) return
19032       i=resi
19033       j=resj
19034       k=resk
19035 !C      write(iout,*) resi,resj,resk
19036       itypi=itype(i,1)
19037       dxi=dc_norm(1,nres+i)
19038       dyi=dc_norm(2,nres+i)
19039       dzi=dc_norm(3,nres+i)
19040       dsci_inv=vbld_inv(i+nres)
19041       xi=c(1,nres+i)
19042       yi=c(2,nres+i)
19043       zi=c(3,nres+i)
19044       itypj=itype(j,1)
19045       xj=c(1,nres+j)
19046       yj=c(2,nres+j)
19047       zj=c(3,nres+j)
19048
19049       dxj=dc_norm(1,nres+j)
19050       dyj=dc_norm(2,nres+j)
19051       dzj=dc_norm(3,nres+j)
19052       dscj_inv=vbld_inv(j+nres)
19053       itypk=itype(k,1)
19054       xk=c(1,nres+k)
19055       yk=c(2,nres+k)
19056       zk=c(3,nres+k)
19057
19058       dxk=dc_norm(1,nres+k)
19059       dyk=dc_norm(2,nres+k)
19060       dzk=dc_norm(3,nres+k)
19061       dscj_inv=vbld_inv(k+nres)
19062       xij=xj-xi
19063       xik=xk-xi
19064       xjk=xk-xj
19065       yij=yj-yi
19066       yik=yk-yi
19067       yjk=yk-yj
19068       zij=zj-zi
19069       zik=zk-zi
19070       zjk=zk-zj
19071       rrij=(xij*xij+yij*yij+zij*zij)
19072       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19073       rrik=(xik*xik+yik*yik+zik*zik)
19074       rik=dsqrt(rrik)
19075       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19076       rjk=dsqrt(rrjk)
19077 !C there are three combination of distances for each trisulfide bonds
19078 !C The first case the ith atom is the center
19079 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19080 !C distance y is second distance the a,b,c,d are parameters derived for
19081 !C this problem d parameter was set as a penalty currenlty set to 1.
19082       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19083       eij1=0.0d0
19084       else
19085       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19086       endif
19087 !C second case jth atom is center
19088       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19089       eij2=0.0d0
19090       else
19091       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19092       endif
19093 !C the third case kth atom is the center
19094       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19095       eij3=0.0d0
19096       else
19097       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19098       endif
19099 !C      eij2=0.0
19100 !C      eij3=0.0
19101 !C      eij1=0.0
19102       eij=eij1+eij2+eij3
19103 !C      write(iout,*)i,j,k,eij
19104 !C The energy penalty calculated now time for the gradient part
19105 !C derivative over rij
19106       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19107       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19108             gg(1)=xij*fac/rij
19109             gg(2)=yij*fac/rij
19110             gg(3)=zij*fac/rij
19111       do m=1,3
19112         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19113         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19114       enddo
19115
19116       do l=1,3
19117         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19118         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19119       enddo
19120 !C now derivative over rik
19121       fac=-eij1**2/dtriss* &
19122       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19123       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19124             gg(1)=xik*fac/rik
19125             gg(2)=yik*fac/rik
19126             gg(3)=zik*fac/rik
19127       do m=1,3
19128         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19129         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19130       enddo
19131       do l=1,3
19132         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19133         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19134       enddo
19135 !C now derivative over rjk
19136       fac=-eij2**2/dtriss* &
19137       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19138       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19139             gg(1)=xjk*fac/rjk
19140             gg(2)=yjk*fac/rjk
19141             gg(3)=zjk*fac/rjk
19142       do m=1,3
19143         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19144         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19145       enddo
19146       do l=1,3
19147         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19148         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19149       enddo
19150       return
19151       end subroutine triple_ssbond_ene
19152
19153
19154
19155 !-----------------------------------------------------------------------------
19156       real(kind=8) function h_base(x,deriv)
19157 !     A smooth function going 0->1 in range [0,1]
19158 !     It should NOT be called outside range [0,1], it will not work there.
19159       implicit none
19160
19161 !     Input arguments
19162       real(kind=8) :: x
19163
19164 !     Output arguments
19165       real(kind=8) :: deriv
19166
19167 !     Local variables
19168       real(kind=8) :: xsq
19169
19170
19171 !     Two parabolas put together.  First derivative zero at extrema
19172 !$$$      if (x.lt.0.5D0) then
19173 !$$$        h_base=2.0D0*x*x
19174 !$$$        deriv=4.0D0*x
19175 !$$$      else
19176 !$$$        deriv=1.0D0-x
19177 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19178 !$$$        deriv=4.0D0*deriv
19179 !$$$      endif
19180
19181 !     Third degree polynomial.  First derivative zero at extrema
19182       h_base=x*x*(3.0d0-2.0d0*x)
19183       deriv=6.0d0*x*(1.0d0-x)
19184
19185 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19186 !$$$      xsq=x*x
19187 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19188 !$$$      deriv=x-1.0d0
19189 !$$$      deriv=deriv*deriv
19190 !$$$      deriv=30.0d0*xsq*deriv
19191
19192       return
19193       end function h_base
19194 !-----------------------------------------------------------------------------
19195       subroutine dyn_set_nss
19196 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19197 !      implicit none
19198       use MD_data, only: totT,t_bath
19199 !     Includes
19200 !      include 'DIMENSIONS'
19201 #ifdef MPI
19202       include "mpif.h"
19203 #endif
19204 !      include 'COMMON.SBRIDGE'
19205 !      include 'COMMON.CHAIN'
19206 !      include 'COMMON.IOUNITS'
19207 !      include 'COMMON.SETUP'
19208 !      include 'COMMON.MD'
19209 !     Local variables
19210       real(kind=8) :: emin
19211       integer :: i,j,imin,ierr
19212       integer :: diff,allnss,newnss
19213       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19214                 newihpb,newjhpb
19215       logical :: found
19216       integer,dimension(0:nfgtasks) :: i_newnss
19217       integer,dimension(0:nfgtasks) :: displ
19218       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19219       integer :: g_newnss
19220
19221       allnss=0
19222       do i=1,nres-1
19223         do j=i+1,nres
19224           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19225             allnss=allnss+1
19226             allflag(allnss)=0
19227             allihpb(allnss)=i
19228             alljhpb(allnss)=j
19229           endif
19230         enddo
19231       enddo
19232
19233 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19234
19235  1    emin=1.0d300
19236       do i=1,allnss
19237         if (allflag(i).eq.0 .and. &
19238              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19239           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19240           imin=i
19241         endif
19242       enddo
19243       if (emin.lt.1.0d300) then
19244         allflag(imin)=1
19245         do i=1,allnss
19246           if (allflag(i).eq.0 .and. &
19247                (allihpb(i).eq.allihpb(imin) .or. &
19248                alljhpb(i).eq.allihpb(imin) .or. &
19249                allihpb(i).eq.alljhpb(imin) .or. &
19250                alljhpb(i).eq.alljhpb(imin))) then
19251             allflag(i)=-1
19252           endif
19253         enddo
19254         goto 1
19255       endif
19256
19257 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19258
19259       newnss=0
19260       do i=1,allnss
19261         if (allflag(i).eq.1) then
19262           newnss=newnss+1
19263           newihpb(newnss)=allihpb(i)
19264           newjhpb(newnss)=alljhpb(i)
19265         endif
19266       enddo
19267
19268 #ifdef MPI
19269       if (nfgtasks.gt.1)then
19270
19271         call MPI_Reduce(newnss,g_newnss,1,&
19272           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19273         call MPI_Gather(newnss,1,MPI_INTEGER,&
19274                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19275         displ(0)=0
19276         do i=1,nfgtasks-1,1
19277           displ(i)=i_newnss(i-1)+displ(i-1)
19278         enddo
19279         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19280                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19281                          king,FG_COMM,IERR)
19282         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19283                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19284                          king,FG_COMM,IERR)
19285         if(fg_rank.eq.0) then
19286 !         print *,'g_newnss',g_newnss
19287 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19288 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19289          newnss=g_newnss
19290          do i=1,newnss
19291           newihpb(i)=g_newihpb(i)
19292           newjhpb(i)=g_newjhpb(i)
19293          enddo
19294         endif
19295       endif
19296 #endif
19297
19298       diff=newnss-nss
19299
19300 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19301 !       print *,newnss,nss,maxdim
19302       do i=1,nss
19303         found=.false.
19304 !        print *,newnss
19305         do j=1,newnss
19306 !!          print *,j
19307           if (idssb(i).eq.newihpb(j) .and. &
19308                jdssb(i).eq.newjhpb(j)) found=.true.
19309         enddo
19310 #ifndef CLUST
19311 #ifndef WHAM
19312 !        write(iout,*) "found",found,i,j
19313         if (.not.found.and.fg_rank.eq.0) &
19314             write(iout,'(a15,f12.2,f8.1,2i5)') &
19315              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19316 #endif
19317 #endif
19318       enddo
19319
19320       do i=1,newnss
19321         found=.false.
19322         do j=1,nss
19323 !          print *,i,j
19324           if (newihpb(i).eq.idssb(j) .and. &
19325                newjhpb(i).eq.jdssb(j)) found=.true.
19326         enddo
19327 #ifndef CLUST
19328 #ifndef WHAM
19329 !        write(iout,*) "found",found,i,j
19330         if (.not.found.and.fg_rank.eq.0) &
19331             write(iout,'(a15,f12.2,f8.1,2i5)') &
19332              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19333 #endif
19334 #endif
19335       enddo
19336
19337       nss=newnss
19338       do i=1,nss
19339         idssb(i)=newihpb(i)
19340         jdssb(i)=newjhpb(i)
19341       enddo
19342
19343       return
19344       end subroutine dyn_set_nss
19345 ! Lipid transfer energy function
19346       subroutine Eliptransfer(eliptran)
19347 !C this is done by Adasko
19348 !C      print *,"wchodze"
19349 !C structure of box:
19350 !C      water
19351 !C--bordliptop-- buffore starts
19352 !C--bufliptop--- here true lipid starts
19353 !C      lipid
19354 !C--buflipbot--- lipid ends buffore starts
19355 !C--bordlipbot--buffore ends
19356       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19357       integer :: i
19358       eliptran=0.0
19359 !      print *, "I am in eliptran"
19360       do i=ilip_start,ilip_end
19361 !C       do i=1,1
19362         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19363          cycle
19364
19365         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19366         if (positi.le.0.0) positi=positi+boxzsize
19367 !C        print *,i
19368 !C first for peptide groups
19369 !c for each residue check if it is in lipid or lipid water border area
19370        if ((positi.gt.bordlipbot)  &
19371       .and.(positi.lt.bordliptop)) then
19372 !C the energy transfer exist
19373         if (positi.lt.buflipbot) then
19374 !C what fraction I am in
19375          fracinbuf=1.0d0-      &
19376              ((positi-bordlipbot)/lipbufthick)
19377 !C lipbufthick is thickenes of lipid buffore
19378          sslip=sscalelip(fracinbuf)
19379          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19380          eliptran=eliptran+sslip*pepliptran
19381          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19382          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19383 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19384
19385 !C        print *,"doing sccale for lower part"
19386 !C         print *,i,sslip,fracinbuf,ssgradlip
19387         elseif (positi.gt.bufliptop) then
19388          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19389          sslip=sscalelip(fracinbuf)
19390          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19391          eliptran=eliptran+sslip*pepliptran
19392          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19393          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19394 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19395 !C          print *, "doing sscalefor top part"
19396 !C         print *,i,sslip,fracinbuf,ssgradlip
19397         else
19398          eliptran=eliptran+pepliptran
19399 !C         print *,"I am in true lipid"
19400         endif
19401 !C       else
19402 !C       eliptran=elpitran+0.0 ! I am in water
19403        endif
19404        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19405        enddo
19406 ! here starts the side chain transfer
19407        do i=ilip_start,ilip_end
19408         if (itype(i,1).eq.ntyp1) cycle
19409         positi=(mod(c(3,i+nres),boxzsize))
19410         if (positi.le.0) positi=positi+boxzsize
19411 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19412 !c for each residue check if it is in lipid or lipid water border area
19413 !C       respos=mod(c(3,i+nres),boxzsize)
19414 !C       print *,positi,bordlipbot,buflipbot
19415        if ((positi.gt.bordlipbot) &
19416        .and.(positi.lt.bordliptop)) then
19417 !C the energy transfer exist
19418         if (positi.lt.buflipbot) then
19419          fracinbuf=1.0d0-   &
19420            ((positi-bordlipbot)/lipbufthick)
19421 !C lipbufthick is thickenes of lipid buffore
19422          sslip=sscalelip(fracinbuf)
19423          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19424          eliptran=eliptran+sslip*liptranene(itype(i,1))
19425          gliptranx(3,i)=gliptranx(3,i) &
19426       +ssgradlip*liptranene(itype(i,1))
19427          gliptranc(3,i-1)= gliptranc(3,i-1) &
19428       +ssgradlip*liptranene(itype(i,1))
19429 !C         print *,"doing sccale for lower part"
19430         elseif (positi.gt.bufliptop) then
19431          fracinbuf=1.0d0-  &
19432       ((bordliptop-positi)/lipbufthick)
19433          sslip=sscalelip(fracinbuf)
19434          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19435          eliptran=eliptran+sslip*liptranene(itype(i,1))
19436          gliptranx(3,i)=gliptranx(3,i)  &
19437        +ssgradlip*liptranene(itype(i,1))
19438          gliptranc(3,i-1)= gliptranc(3,i-1) &
19439       +ssgradlip*liptranene(itype(i,1))
19440 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19441         else
19442          eliptran=eliptran+liptranene(itype(i,1))
19443 !C         print *,"I am in true lipid"
19444         endif
19445         endif ! if in lipid or buffor
19446 !C       else
19447 !C       eliptran=elpitran+0.0 ! I am in water
19448         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19449        enddo
19450        return
19451        end  subroutine Eliptransfer
19452 !----------------------------------NANO FUNCTIONS
19453 !C-----------------------------------------------------------------------
19454 !C-----------------------------------------------------------
19455 !C This subroutine is to mimic the histone like structure but as well can be
19456 !C utilizet to nanostructures (infinit) small modification has to be used to
19457 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19458 !C gradient has to be modified at the ends
19459 !C The energy function is Kihara potential
19460 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19461 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19462 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19463 !C simple Kihara potential
19464       subroutine calctube(Etube)
19465       real(kind=8),dimension(3) :: vectube
19466       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19467        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19468        sc_aa_tube,sc_bb_tube
19469       integer :: i,j,iti
19470       Etube=0.0d0
19471       do i=itube_start,itube_end
19472         enetube(i)=0.0d0
19473         enetube(i+nres)=0.0d0
19474       enddo
19475 !C first we calculate the distance from tube center
19476 !C for UNRES
19477        do i=itube_start,itube_end
19478 !C lets ommit dummy atoms for now
19479        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19480 !C now calculate distance from center of tube and direction vectors
19481       xmin=boxxsize
19482       ymin=boxysize
19483 ! Find minimum distance in periodic box
19484         do j=-1,1
19485          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19486          vectube(1)=vectube(1)+boxxsize*j
19487          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19488          vectube(2)=vectube(2)+boxysize*j
19489          xminact=abs(vectube(1)-tubecenter(1))
19490          yminact=abs(vectube(2)-tubecenter(2))
19491            if (xmin.gt.xminact) then
19492             xmin=xminact
19493             xtemp=vectube(1)
19494            endif
19495            if (ymin.gt.yminact) then
19496              ymin=yminact
19497              ytemp=vectube(2)
19498             endif
19499          enddo
19500       vectube(1)=xtemp
19501       vectube(2)=ytemp
19502       vectube(1)=vectube(1)-tubecenter(1)
19503       vectube(2)=vectube(2)-tubecenter(2)
19504
19505 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19506 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19507
19508 !C as the tube is infinity we do not calculate the Z-vector use of Z
19509 !C as chosen axis
19510       vectube(3)=0.0d0
19511 !C now calculte the distance
19512        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19513 !C now normalize vector
19514       vectube(1)=vectube(1)/tub_r
19515       vectube(2)=vectube(2)/tub_r
19516 !C calculte rdiffrence between r and r0
19517       rdiff=tub_r-tubeR0
19518 !C and its 6 power
19519       rdiff6=rdiff**6.0d0
19520 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19521        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19522 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19523 !C       print *,rdiff,rdiff6,pep_aa_tube
19524 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19525 !C now we calculate gradient
19526        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19527             6.0d0*pep_bb_tube)/rdiff6/rdiff
19528 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19529 !C     &rdiff,fac
19530 !C now direction of gg_tube vector
19531         do j=1,3
19532         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19533         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19534         enddo
19535         enddo
19536 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19537 !C        print *,gg_tube(1,0),"TU"
19538
19539
19540        do i=itube_start,itube_end
19541 !C Lets not jump over memory as we use many times iti
19542          iti=itype(i,1)
19543 !C lets ommit dummy atoms for now
19544          if ((iti.eq.ntyp1)  &
19545 !C in UNRES uncomment the line below as GLY has no side-chain...
19546 !C      .or.(iti.eq.10)
19547         ) cycle
19548       xmin=boxxsize
19549       ymin=boxysize
19550         do j=-1,1
19551          vectube(1)=mod((c(1,i+nres)),boxxsize)
19552          vectube(1)=vectube(1)+boxxsize*j
19553          vectube(2)=mod((c(2,i+nres)),boxysize)
19554          vectube(2)=vectube(2)+boxysize*j
19555
19556          xminact=abs(vectube(1)-tubecenter(1))
19557          yminact=abs(vectube(2)-tubecenter(2))
19558            if (xmin.gt.xminact) then
19559             xmin=xminact
19560             xtemp=vectube(1)
19561            endif
19562            if (ymin.gt.yminact) then
19563              ymin=yminact
19564              ytemp=vectube(2)
19565             endif
19566          enddo
19567       vectube(1)=xtemp
19568       vectube(2)=ytemp
19569 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19570 !C     &     tubecenter(2)
19571       vectube(1)=vectube(1)-tubecenter(1)
19572       vectube(2)=vectube(2)-tubecenter(2)
19573
19574 !C as the tube is infinity we do not calculate the Z-vector use of Z
19575 !C as chosen axis
19576       vectube(3)=0.0d0
19577 !C now calculte the distance
19578        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19579 !C now normalize vector
19580       vectube(1)=vectube(1)/tub_r
19581       vectube(2)=vectube(2)/tub_r
19582
19583 !C calculte rdiffrence between r and r0
19584       rdiff=tub_r-tubeR0
19585 !C and its 6 power
19586       rdiff6=rdiff**6.0d0
19587 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19588        sc_aa_tube=sc_aa_tube_par(iti)
19589        sc_bb_tube=sc_bb_tube_par(iti)
19590        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19591        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19592              6.0d0*sc_bb_tube/rdiff6/rdiff
19593 !C now direction of gg_tube vector
19594          do j=1,3
19595           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19596           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19597          enddo
19598         enddo
19599         do i=itube_start,itube_end
19600           Etube=Etube+enetube(i)+enetube(i+nres)
19601         enddo
19602 !C        print *,"ETUBE", etube
19603         return
19604         end subroutine calctube
19605 !C TO DO 1) add to total energy
19606 !C       2) add to gradient summation
19607 !C       3) add reading parameters (AND of course oppening of PARAM file)
19608 !C       4) add reading the center of tube
19609 !C       5) add COMMONs
19610 !C       6) add to zerograd
19611 !C       7) allocate matrices
19612
19613
19614 !C-----------------------------------------------------------------------
19615 !C-----------------------------------------------------------
19616 !C This subroutine is to mimic the histone like structure but as well can be
19617 !C utilizet to nanostructures (infinit) small modification has to be used to
19618 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19619 !C gradient has to be modified at the ends
19620 !C The energy function is Kihara potential
19621 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19622 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19623 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19624 !C simple Kihara potential
19625       subroutine calctube2(Etube)
19626             real(kind=8),dimension(3) :: vectube
19627       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19628        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19629        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19630       integer:: i,j,iti
19631       Etube=0.0d0
19632       do i=itube_start,itube_end
19633         enetube(i)=0.0d0
19634         enetube(i+nres)=0.0d0
19635       enddo
19636 !C first we calculate the distance from tube center
19637 !C first sugare-phosphate group for NARES this would be peptide group
19638 !C for UNRES
19639        do i=itube_start,itube_end
19640 !C lets ommit dummy atoms for now
19641
19642        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19643 !C now calculate distance from center of tube and direction vectors
19644 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19645 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19646 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19647 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19648       xmin=boxxsize
19649       ymin=boxysize
19650         do j=-1,1
19651          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19652          vectube(1)=vectube(1)+boxxsize*j
19653          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19654          vectube(2)=vectube(2)+boxysize*j
19655
19656          xminact=abs(vectube(1)-tubecenter(1))
19657          yminact=abs(vectube(2)-tubecenter(2))
19658            if (xmin.gt.xminact) then
19659             xmin=xminact
19660             xtemp=vectube(1)
19661            endif
19662            if (ymin.gt.yminact) then
19663              ymin=yminact
19664              ytemp=vectube(2)
19665             endif
19666          enddo
19667       vectube(1)=xtemp
19668       vectube(2)=ytemp
19669       vectube(1)=vectube(1)-tubecenter(1)
19670       vectube(2)=vectube(2)-tubecenter(2)
19671
19672 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19673 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19674
19675 !C as the tube is infinity we do not calculate the Z-vector use of Z
19676 !C as chosen axis
19677       vectube(3)=0.0d0
19678 !C now calculte the distance
19679        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19680 !C now normalize vector
19681       vectube(1)=vectube(1)/tub_r
19682       vectube(2)=vectube(2)/tub_r
19683 !C calculte rdiffrence between r and r0
19684       rdiff=tub_r-tubeR0
19685 !C and its 6 power
19686       rdiff6=rdiff**6.0d0
19687 !C THIS FRAGMENT MAKES TUBE FINITE
19688         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19689         if (positi.le.0) positi=positi+boxzsize
19690 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19691 !c for each residue check if it is in lipid or lipid water border area
19692 !C       respos=mod(c(3,i+nres),boxzsize)
19693 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19694        if ((positi.gt.bordtubebot)  &
19695         .and.(positi.lt.bordtubetop)) then
19696 !C the energy transfer exist
19697         if (positi.lt.buftubebot) then
19698          fracinbuf=1.0d0-  &
19699            ((positi-bordtubebot)/tubebufthick)
19700 !C lipbufthick is thickenes of lipid buffore
19701          sstube=sscalelip(fracinbuf)
19702          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19703 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19704          enetube(i)=enetube(i)+sstube*tubetranenepep
19705 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19706 !C     &+ssgradtube*tubetranene(itype(i,1))
19707 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19708 !C     &+ssgradtube*tubetranene(itype(i,1))
19709 !C         print *,"doing sccale for lower part"
19710         elseif (positi.gt.buftubetop) then
19711          fracinbuf=1.0d0-  &
19712         ((bordtubetop-positi)/tubebufthick)
19713          sstube=sscalelip(fracinbuf)
19714          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19715          enetube(i)=enetube(i)+sstube*tubetranenepep
19716 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19717 !C     &+ssgradtube*tubetranene(itype(i,1))
19718 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19719 !C     &+ssgradtube*tubetranene(itype(i,1))
19720 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19721         else
19722          sstube=1.0d0
19723          ssgradtube=0.0d0
19724          enetube(i)=enetube(i)+sstube*tubetranenepep
19725 !C         print *,"I am in true lipid"
19726         endif
19727         else
19728 !C          sstube=0.0d0
19729 !C          ssgradtube=0.0d0
19730         cycle
19731         endif ! if in lipid or buffor
19732
19733 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19734        enetube(i)=enetube(i)+sstube* &
19735         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19736 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19737 !C       print *,rdiff,rdiff6,pep_aa_tube
19738 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19739 !C now we calculate gradient
19740        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19741              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19742 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19743 !C     &rdiff,fac
19744
19745 !C now direction of gg_tube vector
19746        do j=1,3
19747         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19748         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19749         enddo
19750          gg_tube(3,i)=gg_tube(3,i)  &
19751        +ssgradtube*enetube(i)/sstube/2.0d0
19752          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19753        +ssgradtube*enetube(i)/sstube/2.0d0
19754
19755         enddo
19756 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19757 !C        print *,gg_tube(1,0),"TU"
19758         do i=itube_start,itube_end
19759 !C Lets not jump over memory as we use many times iti
19760          iti=itype(i,1)
19761 !C lets ommit dummy atoms for now
19762          if ((iti.eq.ntyp1) &
19763 !!C in UNRES uncomment the line below as GLY has no side-chain...
19764            .or.(iti.eq.10) &
19765           ) cycle
19766           vectube(1)=c(1,i+nres)
19767           vectube(1)=mod(vectube(1),boxxsize)
19768           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19769           vectube(2)=c(2,i+nres)
19770           vectube(2)=mod(vectube(2),boxysize)
19771           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19772
19773       vectube(1)=vectube(1)-tubecenter(1)
19774       vectube(2)=vectube(2)-tubecenter(2)
19775 !C THIS FRAGMENT MAKES TUBE FINITE
19776         positi=(mod(c(3,i+nres),boxzsize))
19777         if (positi.le.0) positi=positi+boxzsize
19778 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19779 !c for each residue check if it is in lipid or lipid water border area
19780 !C       respos=mod(c(3,i+nres),boxzsize)
19781 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19782
19783        if ((positi.gt.bordtubebot)  &
19784         .and.(positi.lt.bordtubetop)) then
19785 !C the energy transfer exist
19786         if (positi.lt.buftubebot) then
19787          fracinbuf=1.0d0- &
19788             ((positi-bordtubebot)/tubebufthick)
19789 !C lipbufthick is thickenes of lipid buffore
19790          sstube=sscalelip(fracinbuf)
19791          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19792 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19793          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19794 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19795 !C     &+ssgradtube*tubetranene(itype(i,1))
19796 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19797 !C     &+ssgradtube*tubetranene(itype(i,1))
19798 !C         print *,"doing sccale for lower part"
19799         elseif (positi.gt.buftubetop) then
19800          fracinbuf=1.0d0- &
19801         ((bordtubetop-positi)/tubebufthick)
19802
19803          sstube=sscalelip(fracinbuf)
19804          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19805          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19806 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19807 !C     &+ssgradtube*tubetranene(itype(i,1))
19808 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19809 !C     &+ssgradtube*tubetranene(itype(i,1))
19810 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19811         else
19812          sstube=1.0d0
19813          ssgradtube=0.0d0
19814          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19815 !C         print *,"I am in true lipid"
19816         endif
19817         else
19818 !C          sstube=0.0d0
19819 !C          ssgradtube=0.0d0
19820         cycle
19821         endif ! if in lipid or buffor
19822 !CEND OF FINITE FRAGMENT
19823 !C as the tube is infinity we do not calculate the Z-vector use of Z
19824 !C as chosen axis
19825       vectube(3)=0.0d0
19826 !C now calculte the distance
19827        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19828 !C now normalize vector
19829       vectube(1)=vectube(1)/tub_r
19830       vectube(2)=vectube(2)/tub_r
19831 !C calculte rdiffrence between r and r0
19832       rdiff=tub_r-tubeR0
19833 !C and its 6 power
19834       rdiff6=rdiff**6.0d0
19835 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19836        sc_aa_tube=sc_aa_tube_par(iti)
19837        sc_bb_tube=sc_bb_tube_par(iti)
19838        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19839                        *sstube+enetube(i+nres)
19840 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19841 !C now we calculate gradient
19842        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19843             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19844 !C now direction of gg_tube vector
19845          do j=1,3
19846           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19847           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19848          enddo
19849          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19850        +ssgradtube*enetube(i+nres)/sstube
19851          gg_tube(3,i-1)= gg_tube(3,i-1) &
19852        +ssgradtube*enetube(i+nres)/sstube
19853
19854         enddo
19855         do i=itube_start,itube_end
19856           Etube=Etube+enetube(i)+enetube(i+nres)
19857         enddo
19858 !C        print *,"ETUBE", etube
19859         return
19860         end subroutine calctube2
19861 !=====================================================================================================================================
19862       subroutine calcnano(Etube)
19863       real(kind=8),dimension(3) :: vectube
19864
19865       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19866        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19867        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19868        integer:: i,j,iti,r
19869
19870       Etube=0.0d0
19871 !      print *,itube_start,itube_end,"poczatek"
19872       do i=itube_start,itube_end
19873         enetube(i)=0.0d0
19874         enetube(i+nres)=0.0d0
19875       enddo
19876 !C first we calculate the distance from tube center
19877 !C first sugare-phosphate group for NARES this would be peptide group
19878 !C for UNRES
19879        do i=itube_start,itube_end
19880 !C lets ommit dummy atoms for now
19881        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19882 !C now calculate distance from center of tube and direction vectors
19883       xmin=boxxsize
19884       ymin=boxysize
19885       zmin=boxzsize
19886
19887         do j=-1,1
19888          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19889          vectube(1)=vectube(1)+boxxsize*j
19890          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19891          vectube(2)=vectube(2)+boxysize*j
19892          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19893          vectube(3)=vectube(3)+boxzsize*j
19894
19895
19896          xminact=dabs(vectube(1)-tubecenter(1))
19897          yminact=dabs(vectube(2)-tubecenter(2))
19898          zminact=dabs(vectube(3)-tubecenter(3))
19899
19900            if (xmin.gt.xminact) then
19901             xmin=xminact
19902             xtemp=vectube(1)
19903            endif
19904            if (ymin.gt.yminact) then
19905              ymin=yminact
19906              ytemp=vectube(2)
19907             endif
19908            if (zmin.gt.zminact) then
19909              zmin=zminact
19910              ztemp=vectube(3)
19911             endif
19912          enddo
19913       vectube(1)=xtemp
19914       vectube(2)=ytemp
19915       vectube(3)=ztemp
19916
19917       vectube(1)=vectube(1)-tubecenter(1)
19918       vectube(2)=vectube(2)-tubecenter(2)
19919       vectube(3)=vectube(3)-tubecenter(3)
19920
19921 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19922 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19923 !C as the tube is infinity we do not calculate the Z-vector use of Z
19924 !C as chosen axis
19925 !C      vectube(3)=0.0d0
19926 !C now calculte the distance
19927        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19928 !C now normalize vector
19929       vectube(1)=vectube(1)/tub_r
19930       vectube(2)=vectube(2)/tub_r
19931       vectube(3)=vectube(3)/tub_r
19932 !C calculte rdiffrence between r and r0
19933       rdiff=tub_r-tubeR0
19934 !C and its 6 power
19935       rdiff6=rdiff**6.0d0
19936 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19937        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19938 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19939 !C       print *,rdiff,rdiff6,pep_aa_tube
19940 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19941 !C now we calculate gradient
19942        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19943             6.0d0*pep_bb_tube)/rdiff6/rdiff
19944 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19945 !C     &rdiff,fac
19946          if (acavtubpep.eq.0.0d0) then
19947 !C go to 667
19948          enecavtube(i)=0.0
19949          faccav=0.0
19950          else
19951          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19952          enecavtube(i)=  &
19953         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19954         /denominator
19955          enecavtube(i)=0.0
19956          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19957         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19958         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19959         /denominator**2.0d0
19960 !C         faccav=0.0
19961 !C         fac=fac+faccav
19962 !C 667     continue
19963          endif
19964           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19965         do j=1,3
19966         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19967         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19968         enddo
19969         enddo
19970
19971        do i=itube_start,itube_end
19972         enecavtube(i)=0.0d0
19973 !C Lets not jump over memory as we use many times iti
19974          iti=itype(i,1)
19975 !C lets ommit dummy atoms for now
19976          if ((iti.eq.ntyp1) &
19977 !C in UNRES uncomment the line below as GLY has no side-chain...
19978 !C      .or.(iti.eq.10)
19979          ) cycle
19980       xmin=boxxsize
19981       ymin=boxysize
19982       zmin=boxzsize
19983         do j=-1,1
19984          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19985          vectube(1)=vectube(1)+boxxsize*j
19986          vectube(2)=dmod((c(2,i+nres)),boxysize)
19987          vectube(2)=vectube(2)+boxysize*j
19988          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19989          vectube(3)=vectube(3)+boxzsize*j
19990
19991
19992          xminact=dabs(vectube(1)-tubecenter(1))
19993          yminact=dabs(vectube(2)-tubecenter(2))
19994          zminact=dabs(vectube(3)-tubecenter(3))
19995
19996            if (xmin.gt.xminact) then
19997             xmin=xminact
19998             xtemp=vectube(1)
19999            endif
20000            if (ymin.gt.yminact) then
20001              ymin=yminact
20002              ytemp=vectube(2)
20003             endif
20004            if (zmin.gt.zminact) then
20005              zmin=zminact
20006              ztemp=vectube(3)
20007             endif
20008          enddo
20009       vectube(1)=xtemp
20010       vectube(2)=ytemp
20011       vectube(3)=ztemp
20012
20013 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20014 !C     &     tubecenter(2)
20015       vectube(1)=vectube(1)-tubecenter(1)
20016       vectube(2)=vectube(2)-tubecenter(2)
20017       vectube(3)=vectube(3)-tubecenter(3)
20018 !C now calculte the distance
20019        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20020 !C now normalize vector
20021       vectube(1)=vectube(1)/tub_r
20022       vectube(2)=vectube(2)/tub_r
20023       vectube(3)=vectube(3)/tub_r
20024
20025 !C calculte rdiffrence between r and r0
20026       rdiff=tub_r-tubeR0
20027 !C and its 6 power
20028       rdiff6=rdiff**6.0d0
20029        sc_aa_tube=sc_aa_tube_par(iti)
20030        sc_bb_tube=sc_bb_tube_par(iti)
20031        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20032 !C       enetube(i+nres)=0.0d0
20033 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20034 !C now we calculate gradient
20035        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20036             6.0d0*sc_bb_tube/rdiff6/rdiff
20037 !C       fac=0.0
20038 !C now direction of gg_tube vector
20039 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20040          if (acavtub(iti).eq.0.0d0) then
20041 !C go to 667
20042          enecavtube(i+nres)=0.0d0
20043          faccav=0.0d0
20044          else
20045          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20046          enecavtube(i+nres)=   &
20047         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20048         /denominator
20049 !C         enecavtube(i)=0.0
20050          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20051         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20052         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20053         /denominator**2.0d0
20054 !C         faccav=0.0
20055          fac=fac+faccav
20056 !C 667     continue
20057          endif
20058 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20059 !C     &   enecavtube(i),faccav
20060 !C         print *,"licz=",
20061 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20062 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20063          do j=1,3
20064           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20065           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20066          enddo
20067           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20068         enddo
20069
20070
20071
20072         do i=itube_start,itube_end
20073           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20074          +enecavtube(i+nres)
20075         enddo
20076 !        do i=1,20
20077 !         print *,"begin", i,"a"
20078 !         do r=1,10000
20079 !          rdiff=r/100.0d0
20080 !          rdiff6=rdiff**6.0d0
20081 !          sc_aa_tube=sc_aa_tube_par(i)
20082 !          sc_bb_tube=sc_bb_tube_par(i)
20083 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20084 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20085 !          enecavtube(i)=   &
20086 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20087 !         /denominator
20088
20089 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20090 !         enddo
20091 !         print *,"end",i,"a"
20092 !        enddo
20093 !C        print *,"ETUBE", etube
20094         return
20095         end subroutine calcnano
20096
20097 !===============================================
20098 !--------------------------------------------------------------------------------
20099 !C first for shielding is setting of function of side-chains
20100
20101        subroutine set_shield_fac2
20102        real(kind=8) :: div77_81=0.974996043d0, &
20103         div4_81=0.2222222222d0
20104        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20105          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20106          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20107          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20108 !C the vector between center of side_chain and peptide group
20109        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20110          pept_group,costhet_grad,cosphi_grad_long, &
20111          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20112          sh_frac_dist_grad,pep_side
20113         integer i,j,k
20114 !C      write(2,*) "ivec",ivec_start,ivec_end
20115       do i=1,nres
20116         fac_shield(i)=0.0d0
20117         ishield_list(i)=0
20118         do j=1,3
20119         grad_shield(j,i)=0.0d0
20120         enddo
20121       enddo
20122       do i=ivec_start,ivec_end
20123 !C      do i=1,nres-1
20124 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20125 !      ishield_list(i)=0
20126       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20127 !Cif there two consequtive dummy atoms there is no peptide group between them
20128 !C the line below has to be changed for FGPROC>1
20129       VolumeTotal=0.0
20130       do k=1,nres
20131        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20132        dist_pep_side=0.0
20133        dist_side_calf=0.0
20134        do j=1,3
20135 !C first lets set vector conecting the ithe side-chain with kth side-chain
20136       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20137 !C      pep_side(j)=2.0d0
20138 !C and vector conecting the side-chain with its proper calfa
20139       side_calf(j)=c(j,k+nres)-c(j,k)
20140 !C      side_calf(j)=2.0d0
20141       pept_group(j)=c(j,i)-c(j,i+1)
20142 !C lets have their lenght
20143       dist_pep_side=pep_side(j)**2+dist_pep_side
20144       dist_side_calf=dist_side_calf+side_calf(j)**2
20145       dist_pept_group=dist_pept_group+pept_group(j)**2
20146       enddo
20147        dist_pep_side=sqrt(dist_pep_side)
20148        dist_pept_group=sqrt(dist_pept_group)
20149        dist_side_calf=sqrt(dist_side_calf)
20150       do j=1,3
20151         pep_side_norm(j)=pep_side(j)/dist_pep_side
20152         side_calf_norm(j)=dist_side_calf
20153       enddo
20154 !C now sscale fraction
20155        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20156 !       print *,buff_shield,"buff",sh_frac_dist
20157 !C now sscale
20158         if (sh_frac_dist.le.0.0) cycle
20159 !C        print *,ishield_list(i),i
20160 !C If we reach here it means that this side chain reaches the shielding sphere
20161 !C Lets add him to the list for gradient
20162         ishield_list(i)=ishield_list(i)+1
20163 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20164 !C this list is essential otherwise problem would be O3
20165         shield_list(ishield_list(i),i)=k
20166 !C Lets have the sscale value
20167         if (sh_frac_dist.gt.1.0) then
20168          scale_fac_dist=1.0d0
20169          do j=1,3
20170          sh_frac_dist_grad(j)=0.0d0
20171          enddo
20172         else
20173          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20174                         *(2.0d0*sh_frac_dist-3.0d0)
20175          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20176                        /dist_pep_side/buff_shield*0.5d0
20177          do j=1,3
20178          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20179 !C         sh_frac_dist_grad(j)=0.0d0
20180 !C         scale_fac_dist=1.0d0
20181 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20182 !C     &                    sh_frac_dist_grad(j)
20183          enddo
20184         endif
20185 !C this is what is now we have the distance scaling now volume...
20186       short=short_r_sidechain(itype(k,1))
20187       long=long_r_sidechain(itype(k,1))
20188       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20189       sinthet=short/dist_pep_side*costhet
20190 !      print *,"SORT",short,long,sinthet,costhet
20191 !C now costhet_grad
20192 !C       costhet=0.6d0
20193 !C       sinthet=0.8
20194        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20195 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20196 !C     &             -short/dist_pep_side**2/costhet)
20197 !C       costhet_fac=0.0d0
20198        do j=1,3
20199          costhet_grad(j)=costhet_fac*pep_side(j)
20200        enddo
20201 !C remember for the final gradient multiply costhet_grad(j)
20202 !C for side_chain by factor -2 !
20203 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20204 !C pep_side0pept_group is vector multiplication
20205       pep_side0pept_group=0.0d0
20206       do j=1,3
20207       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20208       enddo
20209       cosalfa=(pep_side0pept_group/ &
20210       (dist_pep_side*dist_side_calf))
20211       fac_alfa_sin=1.0d0-cosalfa**2
20212       fac_alfa_sin=dsqrt(fac_alfa_sin)
20213       rkprim=fac_alfa_sin*(long-short)+short
20214 !C      rkprim=short
20215
20216 !C now costhet_grad
20217        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20218 !C       cosphi=0.6
20219        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20220        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20221            dist_pep_side**2)
20222 !C       sinphi=0.8
20223        do j=1,3
20224          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20225       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20226       *(long-short)/fac_alfa_sin*cosalfa/ &
20227       ((dist_pep_side*dist_side_calf))* &
20228       ((side_calf(j))-cosalfa* &
20229       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20230 !C       cosphi_grad_long(j)=0.0d0
20231         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20232       *(long-short)/fac_alfa_sin*cosalfa &
20233       /((dist_pep_side*dist_side_calf))* &
20234       (pep_side(j)- &
20235       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20236 !C       cosphi_grad_loc(j)=0.0d0
20237        enddo
20238 !C      print *,sinphi,sinthet
20239       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20240                          /VSolvSphere_div
20241 !C     &                    *wshield
20242 !C now the gradient...
20243       do j=1,3
20244       grad_shield(j,i)=grad_shield(j,i) &
20245 !C gradient po skalowaniu
20246                      +(sh_frac_dist_grad(j)*VofOverlap &
20247 !C  gradient po costhet
20248             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20249         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20250             sinphi/sinthet*costhet*costhet_grad(j) &
20251            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20252         )*wshield
20253 !C grad_shield_side is Cbeta sidechain gradient
20254       grad_shield_side(j,ishield_list(i),i)=&
20255              (sh_frac_dist_grad(j)*-2.0d0&
20256              *VofOverlap&
20257             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20258        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20259             sinphi/sinthet*costhet*costhet_grad(j)&
20260            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20261             )*wshield
20262 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20263 !            sinphi/sinthet,&
20264 !           +sinthet/sinphi,"HERE"
20265        grad_shield_loc(j,ishield_list(i),i)=   &
20266             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20267       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20268             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20269              ))&
20270              *wshield
20271 !         print *,grad_shield_loc(j,ishield_list(i),i)
20272       enddo
20273       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20274       enddo
20275       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20276
20277 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20278       enddo
20279       return
20280       end subroutine set_shield_fac2
20281 !----------------------------------------------------------------------------
20282 ! SOUBROUTINE FOR AFM
20283        subroutine AFMvel(Eafmforce)
20284        use MD_data, only:totTafm
20285       real(kind=8),dimension(3) :: diffafm
20286       real(kind=8) :: afmdist,Eafmforce
20287        integer :: i
20288 !C Only for check grad COMMENT if not used for checkgrad
20289 !C      totT=3.0d0
20290 !C--------------------------------------------------------
20291 !C      print *,"wchodze"
20292       afmdist=0.0d0
20293       Eafmforce=0.0d0
20294       do i=1,3
20295       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20296       afmdist=afmdist+diffafm(i)**2
20297       enddo
20298       afmdist=dsqrt(afmdist)
20299 !      totTafm=3.0
20300       Eafmforce=0.5d0*forceAFMconst &
20301       *(distafminit+totTafm*velAFMconst-afmdist)**2
20302 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20303       do i=1,3
20304       gradafm(i,afmend-1)=-forceAFMconst* &
20305        (distafminit+totTafm*velAFMconst-afmdist) &
20306        *diffafm(i)/afmdist
20307       gradafm(i,afmbeg-1)=forceAFMconst* &
20308       (distafminit+totTafm*velAFMconst-afmdist) &
20309       *diffafm(i)/afmdist
20310       enddo
20311 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20312       return
20313       end subroutine AFMvel
20314 !---------------------------------------------------------
20315        subroutine AFMforce(Eafmforce)
20316
20317       real(kind=8),dimension(3) :: diffafm
20318 !      real(kind=8) ::afmdist
20319       real(kind=8) :: afmdist,Eafmforce
20320       integer :: i
20321       afmdist=0.0d0
20322       Eafmforce=0.0d0
20323       do i=1,3
20324       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20325       afmdist=afmdist+diffafm(i)**2
20326       enddo
20327       afmdist=dsqrt(afmdist)
20328 !      print *,afmdist,distafminit
20329       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20330       do i=1,3
20331       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20332       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20333       enddo
20334 !C      print *,'AFM',Eafmforce
20335       return
20336       end subroutine AFMforce
20337
20338 !-----------------------------------------------------------------------------
20339 #ifdef WHAM
20340       subroutine read_ssHist
20341 !      implicit none
20342 !      Includes
20343 !      include 'DIMENSIONS'
20344 !      include "DIMENSIONS.FREE"
20345 !      include 'COMMON.FREE'
20346 !     Local variables
20347       integer :: i,j
20348       character(len=80) :: controlcard
20349
20350       do i=1,dyn_nssHist
20351         call card_concat(controlcard,.true.)
20352         read(controlcard,*) &
20353              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20354       enddo
20355
20356       return
20357       end subroutine read_ssHist
20358 #endif
20359 !-----------------------------------------------------------------------------
20360       integer function indmat(i,j)
20361 !el
20362 ! get the position of the jth ijth fragment of the chain coordinate system
20363 ! in the fromto array.
20364         integer :: i,j
20365
20366         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20367       return
20368       end function indmat
20369 !-----------------------------------------------------------------------------
20370       real(kind=8) function sigm(x)
20371 !el
20372        real(kind=8) :: x
20373         sigm=0.25d0*x
20374       return
20375       end function sigm
20376 !-----------------------------------------------------------------------------
20377 !-----------------------------------------------------------------------------
20378       subroutine alloc_ener_arrays
20379 !EL Allocation of arrays used by module energy
20380       use MD_data, only: mset
20381 !el local variables
20382       integer :: i,j
20383
20384       if(nres.lt.100) then
20385         maxconts=nres
20386       elseif(nres.lt.200) then
20387         maxconts=0.8*nres      ! Max. number of contacts per residue
20388       else
20389         maxconts=0.6*nres ! (maxconts=maxres/4)
20390       endif
20391       maxcont=12*nres      ! Max. number of SC contacts
20392       maxvar=6*nres      ! Max. number of variables
20393 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20394       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20395 !----------------------
20396 ! arrays in subroutine init_int_table
20397 !el#ifdef MPI
20398 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20399 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20400 !el#endif
20401       allocate(nint_gr(nres))
20402       allocate(nscp_gr(nres))
20403       allocate(ielstart(nres))
20404       allocate(ielend(nres))
20405 !(maxres)
20406       allocate(istart(nres,maxint_gr))
20407       allocate(iend(nres,maxint_gr))
20408 !(maxres,maxint_gr)
20409       allocate(iscpstart(nres,maxint_gr))
20410       allocate(iscpend(nres,maxint_gr))
20411 !(maxres,maxint_gr)
20412       allocate(ielstart_vdw(nres))
20413       allocate(ielend_vdw(nres))
20414 !(maxres)
20415       allocate(nint_gr_nucl(nres))
20416       allocate(nscp_gr_nucl(nres))
20417       allocate(ielstart_nucl(nres))
20418       allocate(ielend_nucl(nres))
20419 !(maxres)
20420       allocate(istart_nucl(nres,maxint_gr))
20421       allocate(iend_nucl(nres,maxint_gr))
20422 !(maxres,maxint_gr)
20423       allocate(iscpstart_nucl(nres,maxint_gr))
20424       allocate(iscpend_nucl(nres,maxint_gr))
20425 !(maxres,maxint_gr)
20426       allocate(ielstart_vdw_nucl(nres))
20427       allocate(ielend_vdw_nucl(nres))
20428
20429       allocate(lentyp(0:nfgtasks-1))
20430 !(0:maxprocs-1)
20431 !----------------------
20432 ! commom.contacts
20433 !      common /contacts/
20434       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20435       allocate(icont(2,maxcont))
20436 !(2,maxcont)
20437 !      common /contacts1/
20438       allocate(num_cont(0:nres+4))
20439 !(maxres)
20440       allocate(jcont(maxconts,nres))
20441 !(maxconts,maxres)
20442       allocate(facont(maxconts,nres))
20443 !(maxconts,maxres)
20444       allocate(gacont(3,maxconts,nres))
20445 !(3,maxconts,maxres)
20446 !      common /contacts_hb/
20447       allocate(gacontp_hb1(3,maxconts,nres))
20448       allocate(gacontp_hb2(3,maxconts,nres))
20449       allocate(gacontp_hb3(3,maxconts,nres))
20450       allocate(gacontm_hb1(3,maxconts,nres))
20451       allocate(gacontm_hb2(3,maxconts,nres))
20452       allocate(gacontm_hb3(3,maxconts,nres))
20453       allocate(gacont_hbr(3,maxconts,nres))
20454       allocate(grij_hb_cont(3,maxconts,nres))
20455 !(3,maxconts,maxres)
20456       allocate(facont_hb(maxconts,nres))
20457
20458       allocate(ees0p(maxconts,nres))
20459       allocate(ees0m(maxconts,nres))
20460       allocate(d_cont(maxconts,nres))
20461       allocate(ees0plist(maxconts,nres))
20462
20463 !(maxconts,maxres)
20464       allocate(num_cont_hb(nres))
20465 !(maxres)
20466       allocate(jcont_hb(maxconts,nres))
20467 !(maxconts,maxres)
20468 !      common /rotat/
20469       allocate(Ug(2,2,nres))
20470       allocate(Ugder(2,2,nres))
20471       allocate(Ug2(2,2,nres))
20472       allocate(Ug2der(2,2,nres))
20473 !(2,2,maxres)
20474       allocate(obrot(2,nres))
20475       allocate(obrot2(2,nres))
20476       allocate(obrot_der(2,nres))
20477       allocate(obrot2_der(2,nres))
20478 !(2,maxres)
20479 !      common /precomp1/
20480       allocate(mu(2,nres))
20481       allocate(muder(2,nres))
20482       allocate(Ub2(2,nres))
20483       Ub2(1,:)=0.0d0
20484       Ub2(2,:)=0.0d0
20485       allocate(Ub2der(2,nres))
20486       allocate(Ctobr(2,nres))
20487       allocate(Ctobrder(2,nres))
20488       allocate(Dtobr2(2,nres))
20489       allocate(Dtobr2der(2,nres))
20490 !(2,maxres)
20491       allocate(EUg(2,2,nres))
20492       allocate(EUgder(2,2,nres))
20493       allocate(CUg(2,2,nres))
20494       allocate(CUgder(2,2,nres))
20495       allocate(DUg(2,2,nres))
20496       allocate(Dugder(2,2,nres))
20497       allocate(DtUg2(2,2,nres))
20498       allocate(DtUg2der(2,2,nres))
20499 !(2,2,maxres)
20500 !      common /precomp2/
20501       allocate(Ug2Db1t(2,nres))
20502       allocate(Ug2Db1tder(2,nres))
20503       allocate(CUgb2(2,nres))
20504       allocate(CUgb2der(2,nres))
20505 !(2,maxres)
20506       allocate(EUgC(2,2,nres))
20507       allocate(EUgCder(2,2,nres))
20508       allocate(EUgD(2,2,nres))
20509       allocate(EUgDder(2,2,nres))
20510       allocate(DtUg2EUg(2,2,nres))
20511       allocate(Ug2DtEUg(2,2,nres))
20512 !(2,2,maxres)
20513       allocate(Ug2DtEUgder(2,2,2,nres))
20514       allocate(DtUg2EUgder(2,2,2,nres))
20515 !(2,2,2,maxres)
20516       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20517       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20518       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20519       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20520
20521       allocate(ctilde(2,2,nres))
20522       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20523       allocate(gtb1(2,nres))
20524       allocate(gtb2(2,nres))
20525       allocate(cc(2,2,nres))
20526       allocate(dd(2,2,nres))
20527       allocate(ee(2,2,nres))
20528       allocate(gtcc(2,2,nres))
20529       allocate(gtdd(2,2,nres))
20530       allocate(gtee(2,2,nres))
20531       allocate(gUb2(2,nres))
20532       allocate(gteUg(2,2,nres))
20533
20534 !      common /rotat_old/
20535       allocate(costab(nres))
20536       allocate(sintab(nres))
20537       allocate(costab2(nres))
20538       allocate(sintab2(nres))
20539 !(maxres)
20540 !      common /dipmat/
20541       allocate(a_chuj(2,2,maxconts,nres))
20542 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20543       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20544 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20545 !      common /contdistrib/
20546       allocate(ncont_sent(nres))
20547       allocate(ncont_recv(nres))
20548
20549       allocate(iat_sent(nres))
20550 !(maxres)
20551       allocate(iint_sent(4,nres,nres))
20552       allocate(iint_sent_local(4,nres,nres))
20553 !(4,maxres,maxres)
20554       allocate(iturn3_sent(4,0:nres+4))
20555       allocate(iturn4_sent(4,0:nres+4))
20556       allocate(iturn3_sent_local(4,nres))
20557       allocate(iturn4_sent_local(4,nres))
20558 !(4,maxres)
20559       allocate(itask_cont_from(0:nfgtasks-1))
20560       allocate(itask_cont_to(0:nfgtasks-1))
20561 !(0:max_fg_procs-1)
20562
20563
20564
20565 !----------------------
20566 ! commom.deriv;
20567 !      common /derivat/
20568       allocate(dcdv(6,maxdim))
20569       allocate(dxdv(6,maxdim))
20570 !(6,maxdim)
20571       allocate(dxds(6,nres))
20572 !(6,maxres)
20573       allocate(gradx(3,-1:nres,0:2))
20574       allocate(gradc(3,-1:nres,0:2))
20575 !(3,maxres,2)
20576       allocate(gvdwx(3,-1:nres))
20577       allocate(gvdwc(3,-1:nres))
20578       allocate(gelc(3,-1:nres))
20579       allocate(gelc_long(3,-1:nres))
20580       allocate(gvdwpp(3,-1:nres))
20581       allocate(gvdwc_scpp(3,-1:nres))
20582       allocate(gradx_scp(3,-1:nres))
20583       allocate(gvdwc_scp(3,-1:nres))
20584       allocate(ghpbx(3,-1:nres))
20585       allocate(ghpbc(3,-1:nres))
20586       allocate(gradcorr(3,-1:nres))
20587       allocate(gradcorr_long(3,-1:nres))
20588       allocate(gradcorr5_long(3,-1:nres))
20589       allocate(gradcorr6_long(3,-1:nres))
20590       allocate(gcorr6_turn_long(3,-1:nres))
20591       allocate(gradxorr(3,-1:nres))
20592       allocate(gradcorr5(3,-1:nres))
20593       allocate(gradcorr6(3,-1:nres))
20594       allocate(gliptran(3,-1:nres))
20595       allocate(gliptranc(3,-1:nres))
20596       allocate(gliptranx(3,-1:nres))
20597       allocate(gshieldx(3,-1:nres))
20598       allocate(gshieldc(3,-1:nres))
20599       allocate(gshieldc_loc(3,-1:nres))
20600       allocate(gshieldx_ec(3,-1:nres))
20601       allocate(gshieldc_ec(3,-1:nres))
20602       allocate(gshieldc_loc_ec(3,-1:nres))
20603       allocate(gshieldx_t3(3,-1:nres))
20604       allocate(gshieldc_t3(3,-1:nres))
20605       allocate(gshieldc_loc_t3(3,-1:nres))
20606       allocate(gshieldx_t4(3,-1:nres))
20607       allocate(gshieldc_t4(3,-1:nres))
20608       allocate(gshieldc_loc_t4(3,-1:nres))
20609       allocate(gshieldx_ll(3,-1:nres))
20610       allocate(gshieldc_ll(3,-1:nres))
20611       allocate(gshieldc_loc_ll(3,-1:nres))
20612       allocate(grad_shield(3,-1:nres))
20613       allocate(gg_tube_sc(3,-1:nres))
20614       allocate(gg_tube(3,-1:nres))
20615       allocate(gradafm(3,-1:nres))
20616       allocate(gradb_nucl(3,-1:nres))
20617       allocate(gradbx_nucl(3,-1:nres))
20618       allocate(gvdwpsb1(3,-1:nres))
20619       allocate(gelpp(3,-1:nres))
20620       allocate(gvdwpsb(3,-1:nres))
20621       allocate(gelsbc(3,-1:nres))
20622       allocate(gelsbx(3,-1:nres))
20623       allocate(gvdwsbx(3,-1:nres))
20624       allocate(gvdwsbc(3,-1:nres))
20625       allocate(gsbloc(3,-1:nres))
20626       allocate(gsblocx(3,-1:nres))
20627       allocate(gradcorr_nucl(3,-1:nres))
20628       allocate(gradxorr_nucl(3,-1:nres))
20629       allocate(gradcorr3_nucl(3,-1:nres))
20630       allocate(gradxorr3_nucl(3,-1:nres))
20631       allocate(gvdwpp_nucl(3,-1:nres))
20632       allocate(gradpepcat(3,-1:nres))
20633       allocate(gradpepcatx(3,-1:nres))
20634       allocate(gradcatcat(3,-1:nres))
20635 !(3,maxres)
20636       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20637       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20638 ! grad for shielding surroing
20639       allocate(gloc(0:maxvar,0:2))
20640       allocate(gloc_x(0:maxvar,2))
20641 !(maxvar,2)
20642       allocate(gel_loc(3,-1:nres))
20643       allocate(gel_loc_long(3,-1:nres))
20644       allocate(gcorr3_turn(3,-1:nres))
20645       allocate(gcorr4_turn(3,-1:nres))
20646       allocate(gcorr6_turn(3,-1:nres))
20647       allocate(gradb(3,-1:nres))
20648       allocate(gradbx(3,-1:nres))
20649 !(3,maxres)
20650       allocate(gel_loc_loc(maxvar))
20651       allocate(gel_loc_turn3(maxvar))
20652       allocate(gel_loc_turn4(maxvar))
20653       allocate(gel_loc_turn6(maxvar))
20654       allocate(gcorr_loc(maxvar))
20655       allocate(g_corr5_loc(maxvar))
20656       allocate(g_corr6_loc(maxvar))
20657 !(maxvar)
20658       allocate(gsccorc(3,-1:nres))
20659       allocate(gsccorx(3,-1:nres))
20660 !(3,maxres)
20661       allocate(gsccor_loc(-1:nres))
20662 !(maxres)
20663       allocate(gvdwx_scbase(3,-1:nres))
20664       allocate(gvdwc_scbase(3,-1:nres))
20665       allocate(gvdwx_pepbase(3,-1:nres))
20666       allocate(gvdwc_pepbase(3,-1:nres))
20667       allocate(gvdwx_scpho(3,-1:nres))
20668       allocate(gvdwc_scpho(3,-1:nres))
20669       allocate(gvdwc_peppho(3,-1:nres))
20670
20671       allocate(dtheta(3,2,-1:nres))
20672 !(3,2,maxres)
20673       allocate(gscloc(3,-1:nres))
20674       allocate(gsclocx(3,-1:nres))
20675 !(3,maxres)
20676       allocate(dphi(3,3,-1:nres))
20677       allocate(dalpha(3,3,-1:nres))
20678       allocate(domega(3,3,-1:nres))
20679 !(3,3,maxres)
20680 !      common /deriv_scloc/
20681       allocate(dXX_C1tab(3,nres))
20682       allocate(dYY_C1tab(3,nres))
20683       allocate(dZZ_C1tab(3,nres))
20684       allocate(dXX_Ctab(3,nres))
20685       allocate(dYY_Ctab(3,nres))
20686       allocate(dZZ_Ctab(3,nres))
20687       allocate(dXX_XYZtab(3,nres))
20688       allocate(dYY_XYZtab(3,nres))
20689       allocate(dZZ_XYZtab(3,nres))
20690 !(3,maxres)
20691 !      common /mpgrad/
20692       allocate(jgrad_start(nres))
20693       allocate(jgrad_end(nres))
20694 !(maxres)
20695 !----------------------
20696
20697 !      common /indices/
20698       allocate(ibond_displ(0:nfgtasks-1))
20699       allocate(ibond_count(0:nfgtasks-1))
20700       allocate(ithet_displ(0:nfgtasks-1))
20701       allocate(ithet_count(0:nfgtasks-1))
20702       allocate(iphi_displ(0:nfgtasks-1))
20703       allocate(iphi_count(0:nfgtasks-1))
20704       allocate(iphi1_displ(0:nfgtasks-1))
20705       allocate(iphi1_count(0:nfgtasks-1))
20706       allocate(ivec_displ(0:nfgtasks-1))
20707       allocate(ivec_count(0:nfgtasks-1))
20708       allocate(iset_displ(0:nfgtasks-1))
20709       allocate(iset_count(0:nfgtasks-1))
20710       allocate(iint_count(0:nfgtasks-1))
20711       allocate(iint_displ(0:nfgtasks-1))
20712 !(0:max_fg_procs-1)
20713 !----------------------
20714 ! common.MD
20715 !      common /mdgrad/
20716       allocate(gcart(3,-1:nres))
20717       allocate(gxcart(3,-1:nres))
20718 !(3,0:MAXRES)
20719       allocate(gradcag(3,-1:nres))
20720       allocate(gradxag(3,-1:nres))
20721 !(3,MAXRES)
20722 !      common /back_constr/
20723 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20724       allocate(dutheta(nres))
20725       allocate(dugamma(nres))
20726 !(maxres)
20727       allocate(duscdiff(3,nres))
20728       allocate(duscdiffx(3,nres))
20729 !(3,maxres)
20730 !el i io:read_fragments
20731 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20732 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20733 !      common /qmeas/
20734 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20735 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20736       allocate(mset(0:nprocs))  !(maxprocs/20)
20737       mset(:)=0
20738 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20739 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20740       allocate(dUdconst(3,0:nres))
20741       allocate(dUdxconst(3,0:nres))
20742       allocate(dqwol(3,0:nres))
20743       allocate(dxqwol(3,0:nres))
20744 !(3,0:MAXRES)
20745 !----------------------
20746 ! common.sbridge
20747 !      common /sbridge/ in io_common: read_bridge
20748 !el    allocate((:),allocatable :: iss      !(maxss)
20749 !      common /links/  in io_common: read_bridge
20750 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20751 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20752 !      common /dyn_ssbond/
20753 ! and side-chain vectors in theta or phi.
20754       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20755 !(maxres,maxres)
20756 !      do i=1,nres
20757 !        do j=i+1,nres
20758       dyn_ssbond_ij(:,:)=1.0d300
20759 !        enddo
20760 !      enddo
20761
20762 !      if (nss.gt.0) then
20763         allocate(idssb(maxdim),jdssb(maxdim))
20764 !        allocate(newihpb(nss),newjhpb(nss))
20765 !(maxdim)
20766 !      endif
20767       allocate(ishield_list(-1:nres))
20768       allocate(shield_list(maxcontsshi,-1:nres))
20769       allocate(dyn_ss_mask(nres))
20770       allocate(fac_shield(-1:nres))
20771       allocate(enetube(nres*2))
20772       allocate(enecavtube(nres*2))
20773
20774 !(maxres)
20775       dyn_ss_mask(:)=.false.
20776 !----------------------
20777 ! common.sccor
20778 ! Parameters of the SCCOR term
20779 !      common/sccor/
20780 !el in io_conf: parmread
20781 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20782 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20783 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20784 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20785 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20786 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20787 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20788 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20789 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20790 !----------------
20791       allocate(gloc_sc(3,0:2*nres,0:10))
20792 !(3,0:maxres2,10)maxres2=2*maxres
20793       allocate(dcostau(3,3,3,2*nres))
20794       allocate(dsintau(3,3,3,2*nres))
20795       allocate(dtauangle(3,3,3,2*nres))
20796       allocate(dcosomicron(3,3,3,2*nres))
20797       allocate(domicron(3,3,3,2*nres))
20798 !(3,3,3,maxres2)maxres2=2*maxres
20799 !----------------------
20800 ! common.var
20801 !      common /restr/
20802       allocate(varall(maxvar))
20803 !(maxvar)(maxvar=6*maxres)
20804       allocate(mask_theta(nres))
20805       allocate(mask_phi(nres))
20806       allocate(mask_side(nres))
20807 !(maxres)
20808 !----------------------
20809 ! common.vectors
20810 !      common /vectors/
20811       allocate(uy(3,nres))
20812       allocate(uz(3,nres))
20813 !(3,maxres)
20814       allocate(uygrad(3,3,2,nres))
20815       allocate(uzgrad(3,3,2,nres))
20816 !(3,3,2,maxres)
20817
20818       return
20819       end subroutine alloc_ener_arrays
20820 !-----------------------------------------------------------------
20821       subroutine ebond_nucl(estr_nucl)
20822 !c
20823 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20824 !c
20825
20826       real(kind=8),dimension(3) :: u,ud
20827       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20828       real(kind=8) :: estr_nucl,diff
20829       integer :: iti,i,j,k,nbi
20830       estr_nucl=0.0d0
20831 !C      print *,"I enter ebond"
20832       if (energy_dec) &
20833       write (iout,*) "ibondp_start,ibondp_end",&
20834        ibondp_nucl_start,ibondp_nucl_end
20835       do i=ibondp_nucl_start,ibondp_nucl_end
20836         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20837          itype(i,2).eq.ntyp1_molec(2)) cycle
20838 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20839 !          do j=1,3
20840 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20841 !     &      *dc(j,i-1)/vbld(i)
20842 !          enddo
20843 !          if (energy_dec) write(iout,*)
20844 !     &       "estr1",i,vbld(i),distchainmax,
20845 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20846
20847           diff = vbld(i)-vbldp0_nucl
20848           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20849           vbldp0_nucl,diff,AKP_nucl*diff*diff
20850           estr_nucl=estr_nucl+diff*diff
20851 !          print *,estr_nucl
20852           do j=1,3
20853             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20854           enddo
20855 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20856       enddo
20857       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20858 !      print *,"partial sum", estr_nucl,AKP_nucl
20859
20860       if (energy_dec) &
20861       write (iout,*) "ibondp_start,ibondp_end",&
20862        ibond_nucl_start,ibond_nucl_end
20863
20864       do i=ibond_nucl_start,ibond_nucl_end
20865 !C        print *, "I am stuck",i
20866         iti=itype(i,2)
20867         if (iti.eq.ntyp1_molec(2)) cycle
20868           nbi=nbondterm_nucl(iti)
20869 !C        print *,iti,nbi
20870           if (nbi.eq.1) then
20871             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20872
20873             if (energy_dec) &
20874            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20875            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20876             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20877 !            print *,estr_nucl
20878             do j=1,3
20879               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20880             enddo
20881           else
20882             do j=1,nbi
20883               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20884               ud(j)=aksc_nucl(j,iti)*diff
20885               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20886             enddo
20887             uprod=u(1)
20888             do j=2,nbi
20889               uprod=uprod*u(j)
20890             enddo
20891             usum=0.0d0
20892             usumsqder=0.0d0
20893             do j=1,nbi
20894               uprod1=1.0d0
20895               uprod2=1.0d0
20896               do k=1,nbi
20897                 if (k.ne.j) then
20898                   uprod1=uprod1*u(k)
20899                   uprod2=uprod2*u(k)*u(k)
20900                 endif
20901               enddo
20902               usum=usum+uprod1
20903               usumsqder=usumsqder+ud(j)*uprod2
20904             enddo
20905             estr_nucl=estr_nucl+uprod/usum
20906             do j=1,3
20907              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20908             enddo
20909         endif
20910       enddo
20911 !C      print *,"I am about to leave ebond"
20912       return
20913       end subroutine ebond_nucl
20914
20915 !-----------------------------------------------------------------------------
20916       subroutine ebend_nucl(etheta_nucl)
20917       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20918       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20919       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20920       logical :: lprn=.false., lprn1=.false.
20921 !el local variables
20922       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20923       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20924       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20925 ! local variables for constrains
20926       real(kind=8) :: difi,thetiii
20927        integer itheta
20928       etheta_nucl=0.0D0
20929 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20930       do i=ithet_nucl_start,ithet_nucl_end
20931         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20932         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20933         (itype(i,2).eq.ntyp1_molec(2))) cycle
20934         dethetai=0.0d0
20935         dephii=0.0d0
20936         dephii1=0.0d0
20937         theti2=0.5d0*theta(i)
20938         ityp2=ithetyp_nucl(itype(i-1,2))
20939         do k=1,nntheterm_nucl
20940           coskt(k)=dcos(k*theti2)
20941           sinkt(k)=dsin(k*theti2)
20942         enddo
20943         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20944 #ifdef OSF
20945           phii=phi(i)
20946           if (phii.ne.phii) phii=150.0
20947 #else
20948           phii=phi(i)
20949 #endif
20950           ityp1=ithetyp_nucl(itype(i-2,2))
20951           do k=1,nsingle_nucl
20952             cosph1(k)=dcos(k*phii)
20953             sinph1(k)=dsin(k*phii)
20954           enddo
20955         else
20956           phii=0.0d0
20957           ityp1=nthetyp_nucl+1
20958           do k=1,nsingle_nucl
20959             cosph1(k)=0.0d0
20960             sinph1(k)=0.0d0
20961           enddo
20962         endif
20963
20964         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20965 #ifdef OSF
20966           phii1=phi(i+1)
20967           if (phii1.ne.phii1) phii1=150.0
20968           phii1=pinorm(phii1)
20969 #else
20970           phii1=phi(i+1)
20971 #endif
20972           ityp3=ithetyp_nucl(itype(i,2))
20973           do k=1,nsingle_nucl
20974             cosph2(k)=dcos(k*phii1)
20975             sinph2(k)=dsin(k*phii1)
20976           enddo
20977         else
20978           phii1=0.0d0
20979           ityp3=nthetyp_nucl+1
20980           do k=1,nsingle_nucl
20981             cosph2(k)=0.0d0
20982             sinph2(k)=0.0d0
20983           enddo
20984         endif
20985         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20986         do k=1,ndouble_nucl
20987           do l=1,k-1
20988             ccl=cosph1(l)*cosph2(k-l)
20989             ssl=sinph1(l)*sinph2(k-l)
20990             scl=sinph1(l)*cosph2(k-l)
20991             csl=cosph1(l)*sinph2(k-l)
20992             cosph1ph2(l,k)=ccl-ssl
20993             cosph1ph2(k,l)=ccl+ssl
20994             sinph1ph2(l,k)=scl+csl
20995             sinph1ph2(k,l)=scl-csl
20996           enddo
20997         enddo
20998         if (lprn) then
20999         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21000          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21001         write (iout,*) "coskt and sinkt",nntheterm_nucl
21002         do k=1,nntheterm_nucl
21003           write (iout,*) k,coskt(k),sinkt(k)
21004         enddo
21005         endif
21006         do k=1,ntheterm_nucl
21007           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21008           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21009            *coskt(k)
21010           if (lprn)&
21011          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21012           " ethetai",ethetai
21013         enddo
21014         if (lprn) then
21015         write (iout,*) "cosph and sinph"
21016         do k=1,nsingle_nucl
21017           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21018         enddo
21019         write (iout,*) "cosph1ph2 and sinph2ph2"
21020         do k=2,ndouble_nucl
21021           do l=1,k-1
21022             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21023               sinph1ph2(l,k),sinph1ph2(k,l)
21024           enddo
21025         enddo
21026         write(iout,*) "ethetai",ethetai
21027         endif
21028         do m=1,ntheterm2_nucl
21029           do k=1,nsingle_nucl
21030             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21031               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21032               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21033               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21034             ethetai=ethetai+sinkt(m)*aux
21035             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21036             dephii=dephii+k*sinkt(m)*(&
21037                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21038                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21039             dephii1=dephii1+k*sinkt(m)*(&
21040                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21041                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21042             if (lprn) &
21043            write (iout,*) "m",m," k",k," bbthet",&
21044               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21045               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21046               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21047               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21048           enddo
21049         enddo
21050         if (lprn) &
21051         write(iout,*) "ethetai",ethetai
21052         do m=1,ntheterm3_nucl
21053           do k=2,ndouble_nucl
21054             do l=1,k-1
21055               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21056                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21057                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21058                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21059               ethetai=ethetai+sinkt(m)*aux
21060               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21061               dephii=dephii+l*sinkt(m)*(&
21062                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21063                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21064                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21065                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21066               dephii1=dephii1+(k-l)*sinkt(m)*( &
21067                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21068                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21069                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21070                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21071               if (lprn) then
21072               write (iout,*) "m",m," k",k," l",l," ffthet", &
21073                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21074                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21075                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21076                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21077               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21078                  cosph1ph2(k,l)*sinkt(m),&
21079                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21080               endif
21081             enddo
21082           enddo
21083         enddo
21084 10      continue
21085         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21086         i,theta(i)*rad2deg,phii*rad2deg, &
21087         phii1*rad2deg,ethetai
21088         etheta_nucl=etheta_nucl+ethetai
21089 !        print *,i,"partial sum",etheta_nucl
21090         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21091         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21092         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21093       enddo
21094       return
21095       end subroutine ebend_nucl
21096 !----------------------------------------------------
21097       subroutine etor_nucl(etors_nucl)
21098 !      implicit real*8 (a-h,o-z)
21099 !      include 'DIMENSIONS'
21100 !      include 'COMMON.VAR'
21101 !      include 'COMMON.GEO'
21102 !      include 'COMMON.LOCAL'
21103 !      include 'COMMON.TORSION'
21104 !      include 'COMMON.INTERACT'
21105 !      include 'COMMON.DERIV'
21106 !      include 'COMMON.CHAIN'
21107 !      include 'COMMON.NAMES'
21108 !      include 'COMMON.IOUNITS'
21109 !      include 'COMMON.FFIELD'
21110 !      include 'COMMON.TORCNSTR'
21111 !      include 'COMMON.CONTROL'
21112       real(kind=8) :: etors_nucl,edihcnstr
21113       logical :: lprn
21114 !el local variables
21115       integer :: i,j,iblock,itori,itori1
21116       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21117                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21118 ! Set lprn=.true. for debugging
21119       lprn=.false.
21120 !     lprn=.true.
21121       etors_nucl=0.0D0
21122 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21123       do i=iphi_nucl_start,iphi_nucl_end
21124         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21125              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21126              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21127         etors_ii=0.0D0
21128         itori=itortyp_nucl(itype(i-2,2))
21129         itori1=itortyp_nucl(itype(i-1,2))
21130         phii=phi(i)
21131 !         print *,i,itori,itori1
21132         gloci=0.0D0
21133 !C Regular cosine and sine terms
21134         do j=1,nterm_nucl(itori,itori1)
21135           v1ij=v1_nucl(j,itori,itori1)
21136           v2ij=v2_nucl(j,itori,itori1)
21137           cosphi=dcos(j*phii)
21138           sinphi=dsin(j*phii)
21139           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21140           if (energy_dec) etors_ii=etors_ii+&
21141                      v1ij*cosphi+v2ij*sinphi
21142           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21143         enddo
21144 !C Lorentz terms
21145 !C                         v1
21146 !C  E = SUM ----------------------------------- - v1
21147 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21148 !C
21149         cosphi=dcos(0.5d0*phii)
21150         sinphi=dsin(0.5d0*phii)
21151         do j=1,nlor_nucl(itori,itori1)
21152           vl1ij=vlor1_nucl(j,itori,itori1)
21153           vl2ij=vlor2_nucl(j,itori,itori1)
21154           vl3ij=vlor3_nucl(j,itori,itori1)
21155           pom=vl2ij*cosphi+vl3ij*sinphi
21156           pom1=1.0d0/(pom*pom+1.0d0)
21157           etors_nucl=etors_nucl+vl1ij*pom1
21158           if (energy_dec) etors_ii=etors_ii+ &
21159                      vl1ij*pom1
21160           pom=-pom*pom1*pom1
21161           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21162         enddo
21163 !C Subtract the constant term
21164         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21165           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21166               'etor',i,etors_ii-v0_nucl(itori,itori1)
21167         if (lprn) &
21168        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21169        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21170        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21171         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21172 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21173       enddo
21174       return
21175       end subroutine etor_nucl
21176 !------------------------------------------------------------
21177       subroutine epp_nucl_sub(evdw1,ees)
21178 !C
21179 !C This subroutine calculates the average interaction energy and its gradient
21180 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21181 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21182 !C The potential depends both on the distance of peptide-group centers and on
21183 !C the orientation of the CA-CA virtual bonds.
21184 !C
21185       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21186       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21187       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21188                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21189                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21190       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21191                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21192       integer xshift,yshift,zshift
21193       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21194       real(kind=8) :: ees,eesij
21195 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21196       real(kind=8) scal_el /0.5d0/
21197       t_eelecij=0.0d0
21198       ees=0.0D0
21199       evdw1=0.0D0
21200       ind=0
21201 !c
21202 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21203 !c
21204 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21205       do i=iatel_s_nucl,iatel_e_nucl
21206         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21207         dxi=dc(1,i)
21208         dyi=dc(2,i)
21209         dzi=dc(3,i)
21210         dx_normi=dc_norm(1,i)
21211         dy_normi=dc_norm(2,i)
21212         dz_normi=dc_norm(3,i)
21213         xmedi=c(1,i)+0.5d0*dxi
21214         ymedi=c(2,i)+0.5d0*dyi
21215         zmedi=c(3,i)+0.5d0*dzi
21216           xmedi=dmod(xmedi,boxxsize)
21217           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21218           ymedi=dmod(ymedi,boxysize)
21219           if (ymedi.lt.0) ymedi=ymedi+boxysize
21220           zmedi=dmod(zmedi,boxzsize)
21221           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21222
21223         do j=ielstart_nucl(i),ielend_nucl(i)
21224           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21225           ind=ind+1
21226           dxj=dc(1,j)
21227           dyj=dc(2,j)
21228           dzj=dc(3,j)
21229 !          xj=c(1,j)+0.5D0*dxj-xmedi
21230 !          yj=c(2,j)+0.5D0*dyj-ymedi
21231 !          zj=c(3,j)+0.5D0*dzj-zmedi
21232           xj=c(1,j)+0.5D0*dxj
21233           yj=c(2,j)+0.5D0*dyj
21234           zj=c(3,j)+0.5D0*dzj
21235           xj=mod(xj,boxxsize)
21236           if (xj.lt.0) xj=xj+boxxsize
21237           yj=mod(yj,boxysize)
21238           if (yj.lt.0) yj=yj+boxysize
21239           zj=mod(zj,boxzsize)
21240           if (zj.lt.0) zj=zj+boxzsize
21241       isubchap=0
21242       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21243       xj_safe=xj
21244       yj_safe=yj
21245       zj_safe=zj
21246       do xshift=-1,1
21247       do yshift=-1,1
21248       do zshift=-1,1
21249           xj=xj_safe+xshift*boxxsize
21250           yj=yj_safe+yshift*boxysize
21251           zj=zj_safe+zshift*boxzsize
21252           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21253           if(dist_temp.lt.dist_init) then
21254             dist_init=dist_temp
21255             xj_temp=xj
21256             yj_temp=yj
21257             zj_temp=zj
21258             isubchap=1
21259           endif
21260        enddo
21261        enddo
21262        enddo
21263        if (isubchap.eq.1) then
21264 !C          print *,i,j
21265           xj=xj_temp-xmedi
21266           yj=yj_temp-ymedi
21267           zj=zj_temp-zmedi
21268        else
21269           xj=xj_safe-xmedi
21270           yj=yj_safe-ymedi
21271           zj=zj_safe-zmedi
21272        endif
21273
21274           rij=xj*xj+yj*yj+zj*zj
21275 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21276           fac=(r0pp**2/rij)**3
21277           ev1=epspp*fac*fac
21278           ev2=epspp*fac
21279           evdw1ij=ev1-2*ev2
21280           fac=(-ev1-evdw1ij)/rij
21281 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21282           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21283           evdw1=evdw1+evdw1ij
21284 !C
21285 !C Calculate contributions to the Cartesian gradient.
21286 !C
21287           ggg(1)=fac*xj
21288           ggg(2)=fac*yj
21289           ggg(3)=fac*zj
21290           do k=1,3
21291             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21292             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21293           enddo
21294 !c phoshate-phosphate electrostatic interactions
21295           rij=dsqrt(rij)
21296           fac=1.0d0/rij
21297           eesij=dexp(-BEES*rij)*fac
21298 !          write (2,*)"fac",fac," eesijpp",eesij
21299           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21300           ees=ees+eesij
21301 !c          fac=-eesij*fac
21302           fac=-(fac+BEES)*eesij*fac
21303           ggg(1)=fac*xj
21304           ggg(2)=fac*yj
21305           ggg(3)=fac*zj
21306 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21307 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21308 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21309           do k=1,3
21310             gelpp(k,i)=gelpp(k,i)-ggg(k)
21311             gelpp(k,j)=gelpp(k,j)+ggg(k)
21312           enddo
21313         enddo ! j
21314       enddo   ! i
21315 !c      ees=332.0d0*ees
21316       ees=AEES*ees
21317       do i=nnt,nct
21318 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21319         do k=1,3
21320           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21321 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21322           gelpp(k,i)=AEES*gelpp(k,i)
21323         enddo
21324 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21325       enddo
21326 !c      write (2,*) "total EES",ees
21327       return
21328       end subroutine epp_nucl_sub
21329 !---------------------------------------------------------------------
21330       subroutine epsb(evdwpsb,eelpsb)
21331 !      use comm_locel
21332 !C
21333 !C This subroutine calculates the excluded-volume interaction energy between
21334 !C peptide-group centers and side chains and its gradient in virtual-bond and
21335 !C side-chain vectors.
21336 !C
21337       real(kind=8),dimension(3):: ggg
21338       integer :: i,iint,j,k,iteli,itypj,subchap
21339       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21340                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21341       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21342                     dist_temp, dist_init
21343       integer xshift,yshift,zshift
21344
21345 !cd    print '(a)','Enter ESCP'
21346 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21347       eelpsb=0.0d0
21348       evdwpsb=0.0d0
21349 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21350       do i=iatscp_s_nucl,iatscp_e_nucl
21351         if (itype(i,2).eq.ntyp1_molec(2) &
21352          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21353         xi=0.5D0*(c(1,i)+c(1,i+1))
21354         yi=0.5D0*(c(2,i)+c(2,i+1))
21355         zi=0.5D0*(c(3,i)+c(3,i+1))
21356           xi=mod(xi,boxxsize)
21357           if (xi.lt.0) xi=xi+boxxsize
21358           yi=mod(yi,boxysize)
21359           if (yi.lt.0) yi=yi+boxysize
21360           zi=mod(zi,boxzsize)
21361           if (zi.lt.0) zi=zi+boxzsize
21362
21363         do iint=1,nscp_gr_nucl(i)
21364
21365         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21366           itypj=itype(j,2)
21367           if (itypj.eq.ntyp1_molec(2)) cycle
21368 !C Uncomment following three lines for SC-p interactions
21369 !c         xj=c(1,nres+j)-xi
21370 !c         yj=c(2,nres+j)-yi
21371 !c         zj=c(3,nres+j)-zi
21372 !C Uncomment following three lines for Ca-p interactions
21373 !          xj=c(1,j)-xi
21374 !          yj=c(2,j)-yi
21375 !          zj=c(3,j)-zi
21376           xj=c(1,j)
21377           yj=c(2,j)
21378           zj=c(3,j)
21379           xj=mod(xj,boxxsize)
21380           if (xj.lt.0) xj=xj+boxxsize
21381           yj=mod(yj,boxysize)
21382           if (yj.lt.0) yj=yj+boxysize
21383           zj=mod(zj,boxzsize)
21384           if (zj.lt.0) zj=zj+boxzsize
21385       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21386       xj_safe=xj
21387       yj_safe=yj
21388       zj_safe=zj
21389       subchap=0
21390       do xshift=-1,1
21391       do yshift=-1,1
21392       do zshift=-1,1
21393           xj=xj_safe+xshift*boxxsize
21394           yj=yj_safe+yshift*boxysize
21395           zj=zj_safe+zshift*boxzsize
21396           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21397           if(dist_temp.lt.dist_init) then
21398             dist_init=dist_temp
21399             xj_temp=xj
21400             yj_temp=yj
21401             zj_temp=zj
21402             subchap=1
21403           endif
21404        enddo
21405        enddo
21406        enddo
21407        if (subchap.eq.1) then
21408           xj=xj_temp-xi
21409           yj=yj_temp-yi
21410           zj=zj_temp-zi
21411        else
21412           xj=xj_safe-xi
21413           yj=yj_safe-yi
21414           zj=zj_safe-zi
21415        endif
21416
21417           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21418           fac=rrij**expon2
21419           e1=fac*fac*aad_nucl(itypj)
21420           e2=fac*bad_nucl(itypj)
21421           if (iabs(j-i) .le. 2) then
21422             e1=scal14*e1
21423             e2=scal14*e2
21424           endif
21425           evdwij=e1+e2
21426           evdwpsb=evdwpsb+evdwij
21427           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21428              'evdw2',i,j,evdwij,"tu4"
21429 !C
21430 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21431 !C
21432           fac=-(evdwij+e1)*rrij
21433           ggg(1)=xj*fac
21434           ggg(2)=yj*fac
21435           ggg(3)=zj*fac
21436           do k=1,3
21437             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21438             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21439           enddo
21440         enddo
21441
21442         enddo ! iint
21443       enddo ! i
21444       do i=1,nct
21445         do j=1,3
21446           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21447           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21448         enddo
21449       enddo
21450       return
21451       end subroutine epsb
21452
21453 !------------------------------------------------------
21454       subroutine esb_gb(evdwsb,eelsb)
21455       use comm_locel
21456       use calc_data_nucl
21457       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21458       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21459       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21460       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21461                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21462       integer :: ii
21463       logical lprn
21464       evdw=0.0D0
21465       eelsb=0.0d0
21466       ecorr=0.0d0
21467       evdwsb=0.0D0
21468       lprn=.false.
21469       ind=0
21470 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21471       do i=iatsc_s_nucl,iatsc_e_nucl
21472         num_conti=0
21473         num_conti2=0
21474         itypi=itype(i,2)
21475 !        PRINT *,"I=",i,itypi
21476         if (itypi.eq.ntyp1_molec(2)) cycle
21477         itypi1=itype(i+1,2)
21478         xi=c(1,nres+i)
21479         yi=c(2,nres+i)
21480         zi=c(3,nres+i)
21481           xi=dmod(xi,boxxsize)
21482           if (xi.lt.0) xi=xi+boxxsize
21483           yi=dmod(yi,boxysize)
21484           if (yi.lt.0) yi=yi+boxysize
21485           zi=dmod(zi,boxzsize)
21486           if (zi.lt.0) zi=zi+boxzsize
21487
21488         dxi=dc_norm(1,nres+i)
21489         dyi=dc_norm(2,nres+i)
21490         dzi=dc_norm(3,nres+i)
21491         dsci_inv=vbld_inv(i+nres)
21492 !C
21493 !C Calculate SC interaction energy.
21494 !C
21495         do iint=1,nint_gr_nucl(i)
21496 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21497           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21498             ind=ind+1
21499 !            print *,"JESTEM"
21500             itypj=itype(j,2)
21501             if (itypj.eq.ntyp1_molec(2)) cycle
21502             dscj_inv=vbld_inv(j+nres)
21503             sig0ij=sigma_nucl(itypi,itypj)
21504             chi1=chi_nucl(itypi,itypj)
21505             chi2=chi_nucl(itypj,itypi)
21506             chi12=chi1*chi2
21507             chip1=chip_nucl(itypi,itypj)
21508             chip2=chip_nucl(itypj,itypi)
21509             chip12=chip1*chip2
21510 !            xj=c(1,nres+j)-xi
21511 !            yj=c(2,nres+j)-yi
21512 !            zj=c(3,nres+j)-zi
21513            xj=c(1,nres+j)
21514            yj=c(2,nres+j)
21515            zj=c(3,nres+j)
21516           xj=dmod(xj,boxxsize)
21517           if (xj.lt.0) xj=xj+boxxsize
21518           yj=dmod(yj,boxysize)
21519           if (yj.lt.0) yj=yj+boxysize
21520           zj=dmod(zj,boxzsize)
21521           if (zj.lt.0) zj=zj+boxzsize
21522       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21523       xj_safe=xj
21524       yj_safe=yj
21525       zj_safe=zj
21526       subchap=0
21527       do xshift=-1,1
21528       do yshift=-1,1
21529       do zshift=-1,1
21530           xj=xj_safe+xshift*boxxsize
21531           yj=yj_safe+yshift*boxysize
21532           zj=zj_safe+zshift*boxzsize
21533           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21534           if(dist_temp.lt.dist_init) then
21535             dist_init=dist_temp
21536             xj_temp=xj
21537             yj_temp=yj
21538             zj_temp=zj
21539             subchap=1
21540           endif
21541        enddo
21542        enddo
21543        enddo
21544        if (subchap.eq.1) then
21545           xj=xj_temp-xi
21546           yj=yj_temp-yi
21547           zj=zj_temp-zi
21548        else
21549           xj=xj_safe-xi
21550           yj=yj_safe-yi
21551           zj=zj_safe-zi
21552        endif
21553
21554             dxj=dc_norm(1,nres+j)
21555             dyj=dc_norm(2,nres+j)
21556             dzj=dc_norm(3,nres+j)
21557             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21558             rij=dsqrt(rrij)
21559 !C Calculate angle-dependent terms of energy and contributions to their
21560 !C derivatives.
21561             erij(1)=xj*rij
21562             erij(2)=yj*rij
21563             erij(3)=zj*rij
21564             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21565             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21566             om12=dxi*dxj+dyi*dyj+dzi*dzj
21567             call sc_angular_nucl
21568             sigsq=1.0D0/sigsq
21569             sig=sig0ij*dsqrt(sigsq)
21570             rij_shift=1.0D0/rij-sig+sig0ij
21571 !            print *,rij_shift,"rij_shift"
21572 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21573 !c     &       " rij_shift",rij_shift
21574             if (rij_shift.le.0.0D0) then
21575               evdw=1.0D20
21576               return
21577             endif
21578             sigder=-sig*sigsq
21579 !c---------------------------------------------------------------
21580             rij_shift=1.0D0/rij_shift
21581             fac=rij_shift**expon
21582             e1=fac*fac*aa_nucl(itypi,itypj)
21583             e2=fac*bb_nucl(itypi,itypj)
21584             evdwij=eps1*eps2rt*(e1+e2)
21585 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21586 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21587             eps2der=evdwij
21588             evdwij=evdwij*eps2rt
21589             evdwsb=evdwsb+evdwij
21590             if (lprn) then
21591             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21592             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21593             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21594              restyp(itypi,2),i,restyp(itypj,2),j, &
21595              epsi,sigm,chi1,chi2,chip1,chip2, &
21596              eps1,eps2rt**2,sig,sig0ij, &
21597              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21598             evdwij
21599             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21600             endif
21601
21602             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21603                              'evdw',i,j,evdwij,"tu3"
21604
21605
21606 !C Calculate gradient components.
21607             e1=e1*eps1*eps2rt**2
21608             fac=-expon*(e1+evdwij)*rij_shift
21609             sigder=fac*sigder
21610             fac=rij*fac
21611 !c            fac=0.0d0
21612 !C Calculate the radial part of the gradient
21613             gg(1)=xj*fac
21614             gg(2)=yj*fac
21615             gg(3)=zj*fac
21616 !C Calculate angular part of the gradient.
21617             call sc_grad_nucl
21618             call eelsbij(eelij,num_conti2)
21619             if (energy_dec .and. &
21620            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21621           write (istat,'(e14.5)') evdwij
21622             eelsb=eelsb+eelij
21623           enddo      ! j
21624         enddo        ! iint
21625         num_cont_hb(i)=num_conti2
21626       enddo          ! i
21627 !c      write (iout,*) "Number of loop steps in EGB:",ind
21628 !cccc      energy_dec=.false.
21629       return
21630       end subroutine esb_gb
21631 !-------------------------------------------------------------------------------
21632       subroutine eelsbij(eesij,num_conti2)
21633       use comm_locel
21634       use calc_data_nucl
21635       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21636       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21637       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21638                     dist_temp, dist_init,rlocshield,fracinbuf
21639       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21640
21641 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21642       real(kind=8) scal_el /0.5d0/
21643       integer :: iteli,itelj,kkk,kkll,m,isubchap
21644       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21645       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21646       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21647                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21648                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21649                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21650                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21651                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21652                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21653                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21654       ind=ind+1
21655       itypi=itype(i,2)
21656       itypj=itype(j,2)
21657 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21658       ael6i=ael6_nucl(itypi,itypj)
21659       ael3i=ael3_nucl(itypi,itypj)
21660       ael63i=ael63_nucl(itypi,itypj)
21661       ael32i=ael32_nucl(itypi,itypj)
21662 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21663 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21664       dxj=dc(1,j+nres)
21665       dyj=dc(2,j+nres)
21666       dzj=dc(3,j+nres)
21667       dx_normi=dc_norm(1,i+nres)
21668       dy_normi=dc_norm(2,i+nres)
21669       dz_normi=dc_norm(3,i+nres)
21670       dx_normj=dc_norm(1,j+nres)
21671       dy_normj=dc_norm(2,j+nres)
21672       dz_normj=dc_norm(3,j+nres)
21673 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21674 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21675 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21676       if (ipot_nucl.ne.2) then
21677         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21678         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21679         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21680       else
21681         cosa=om12
21682         cosb=om1
21683         cosg=om2
21684       endif
21685       r3ij=rij*rrij
21686       r6ij=r3ij*r3ij
21687       fac=cosa-3.0D0*cosb*cosg
21688       facfac=fac*fac
21689       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21690       fac3=ael6i*r6ij
21691       fac4=ael3i*r3ij
21692       fac5=ael63i*r6ij
21693       fac6=ael32i*r6ij
21694 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21695 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21696       el1=fac3*(4.0D0+facfac-fac1)
21697       el2=fac4*fac
21698       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21699       el4=fac6*facfac
21700       eesij=el1+el2+el3+el4
21701 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21702       ees0ij=4.0D0+facfac-fac1
21703
21704       if (energy_dec) then
21705           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21706           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21707            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21708            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21709            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21710           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21711       endif
21712
21713 !C
21714 !C Calculate contributions to the Cartesian gradient.
21715 !C
21716       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21717       fac1=fac
21718 !c      erij(1)=xj*rmij
21719 !c      erij(2)=yj*rmij
21720 !c      erij(3)=zj*rmij
21721 !*
21722 !* Radial derivatives. First process both termini of the fragment (i,j)
21723 !*
21724       ggg(1)=facel*xj
21725       ggg(2)=facel*yj
21726       ggg(3)=facel*zj
21727       do k=1,3
21728         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21729         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21730         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21731         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21732       enddo
21733 !*
21734 !* Angular part
21735 !*
21736       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21737       fac4=-3.0D0*fac4
21738       fac3=-6.0D0*fac3
21739       fac5= 6.0d0*fac5
21740       fac6=-6.0d0*fac6
21741       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21742        fac6*fac1*cosg
21743       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21744        fac6*fac1*cosb
21745       do k=1,3
21746         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21747         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21748       enddo
21749       do k=1,3
21750         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21751       enddo
21752       do k=1,3
21753         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21754              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21755              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21756         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21757              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21758              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21759         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21760         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21761       enddo
21762 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21763        IF ( j.gt.i+1 .and.&
21764           num_conti.le.maxconts) THEN
21765 !C
21766 !C Calculate the contact function. The ith column of the array JCONT will
21767 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21768 !C greater than I). The arrays FACONT and GACONT will contain the values of
21769 !C the contact function and its derivative.
21770         r0ij=2.20D0*sigma(itypi,itypj)
21771 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21772         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21773 !c        write (2,*) "fcont",fcont
21774         if (fcont.gt.0.0D0) then
21775           num_conti=num_conti+1
21776           num_conti2=num_conti2+1
21777
21778           if (num_conti.gt.maxconts) then
21779             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21780                           ' will skip next contacts for this conf.'
21781           else
21782             jcont_hb(num_conti,i)=j
21783 !c            write (iout,*) "num_conti",num_conti,
21784 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21785 !C Calculate contact energies
21786             cosa4=4.0D0*cosa
21787             wij=cosa-3.0D0*cosb*cosg
21788             cosbg1=cosb+cosg
21789             cosbg2=cosb-cosg
21790             fac3=dsqrt(-ael6i)*r3ij
21791 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21792             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21793             if (ees0tmp.gt.0) then
21794               ees0pij=dsqrt(ees0tmp)
21795             else
21796               ees0pij=0
21797             endif
21798             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21799             if (ees0tmp.gt.0) then
21800               ees0mij=dsqrt(ees0tmp)
21801             else
21802               ees0mij=0
21803             endif
21804             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21805             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21806 !c            write (iout,*) "i",i," j",j,
21807 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21808             ees0pij1=fac3/ees0pij
21809             ees0mij1=fac3/ees0mij
21810             fac3p=-3.0D0*fac3*rrij
21811             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21812             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21813             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21814             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21815             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21816             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21817             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21818             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21819             ecosap=ecosa1+ecosa2
21820             ecosbp=ecosb1+ecosb2
21821             ecosgp=ecosg1+ecosg2
21822             ecosam=ecosa1-ecosa2
21823             ecosbm=ecosb1-ecosb2
21824             ecosgm=ecosg1-ecosg2
21825 !C End diagnostics
21826             facont_hb(num_conti,i)=fcont
21827             fprimcont=fprimcont/rij
21828             do k=1,3
21829               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21830               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21831             enddo
21832             gggp(1)=gggp(1)+ees0pijp*xj
21833             gggp(2)=gggp(2)+ees0pijp*yj
21834             gggp(3)=gggp(3)+ees0pijp*zj
21835             gggm(1)=gggm(1)+ees0mijp*xj
21836             gggm(2)=gggm(2)+ees0mijp*yj
21837             gggm(3)=gggm(3)+ees0mijp*zj
21838 !C Derivatives due to the contact function
21839             gacont_hbr(1,num_conti,i)=fprimcont*xj
21840             gacont_hbr(2,num_conti,i)=fprimcont*yj
21841             gacont_hbr(3,num_conti,i)=fprimcont*zj
21842             do k=1,3
21843 !c
21844 !c Gradient of the correlation terms
21845 !c
21846               gacontp_hb1(k,num_conti,i)= &
21847              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21848             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21849               gacontp_hb2(k,num_conti,i)= &
21850              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21851             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21852               gacontp_hb3(k,num_conti,i)=gggp(k)
21853               gacontm_hb1(k,num_conti,i)= &
21854              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21855             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21856               gacontm_hb2(k,num_conti,i)= &
21857              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21858             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21859               gacontm_hb3(k,num_conti,i)=gggm(k)
21860             enddo
21861           endif
21862         endif
21863       ENDIF
21864       return
21865       end subroutine eelsbij
21866 !------------------------------------------------------------------
21867       subroutine sc_grad_nucl
21868       use comm_locel
21869       use calc_data_nucl
21870       real(kind=8),dimension(3) :: dcosom1,dcosom2
21871       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21872       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21873       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21874       do k=1,3
21875         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21876         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21877       enddo
21878       do k=1,3
21879         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21880       enddo
21881       do k=1,3
21882         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21883                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21884                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21885         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21886                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21887                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21888       enddo
21889 !C
21890 !C Calculate the components of the gradient in DC and X
21891 !C
21892       do l=1,3
21893         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21894         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21895       enddo
21896       return
21897       end subroutine sc_grad_nucl
21898 !-----------------------------------------------------------------------
21899       subroutine esb(esbloc)
21900 !C Calculate the local energy of a side chain and its derivatives in the
21901 !C corresponding virtual-bond valence angles THETA and the spherical angles
21902 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21903 !C added by Urszula Kozlowska. 07/11/2007
21904 !C
21905       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21906       real(kind=8),dimension(9):: x
21907      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21908       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21909       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21910       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21911        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21912        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21913        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21914        integer::it,nlobit,i,j,k
21915 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21916       delta=0.02d0*pi
21917       esbloc=0.0D0
21918       do i=loc_start_nucl,loc_end_nucl
21919         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21920         costtab(i+1) =dcos(theta(i+1))
21921         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21922         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21923         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21924         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21925         cosfac=dsqrt(cosfac2)
21926         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21927         sinfac=dsqrt(sinfac2)
21928         it=itype(i,2)
21929         if (it.eq.10) goto 1
21930
21931 !c
21932 !C  Compute the axes of tghe local cartesian coordinates system; store in
21933 !c   x_prime, y_prime and z_prime
21934 !c
21935         do j=1,3
21936           x_prime(j) = 0.00
21937           y_prime(j) = 0.00
21938           z_prime(j) = 0.00
21939         enddo
21940 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21941 !C     &   dc_norm(3,i+nres)
21942         do j = 1,3
21943           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21944           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21945         enddo
21946         do j = 1,3
21947           z_prime(j) = -uz(j,i-1)
21948 !           z_prime(j)=0.0
21949         enddo
21950
21951         xx=0.0d0
21952         yy=0.0d0
21953         zz=0.0d0
21954         do j = 1,3
21955           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21956           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21957           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21958         enddo
21959
21960         xxtab(i)=xx
21961         yytab(i)=yy
21962         zztab(i)=zz
21963          it=itype(i,2)
21964         do j = 1,9
21965           x(j) = sc_parmin_nucl(j,it)
21966         enddo
21967 #ifdef CHECK_COORD
21968 !Cc diagnostics - remove later
21969         xx1 = dcos(alph(2))
21970         yy1 = dsin(alph(2))*dcos(omeg(2))
21971         zz1 = -dsin(alph(2))*dsin(omeg(2))
21972         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21973          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21974          xx1,yy1,zz1
21975 !C,"  --- ", xx_w,yy_w,zz_w
21976 !c end diagnostics
21977 #endif
21978         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21979         esbloc = esbloc + sumene
21980         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21981 !        print *,"enecomp",sumene,sumene2
21982 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21983 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21984 #ifdef DEBUG
21985         write (2,*) "x",(x(k),k=1,9)
21986 !C
21987 !C This section to check the numerical derivatives of the energy of ith side
21988 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21989 !C #define DEBUG in the code to turn it on.
21990 !C
21991         write (2,*) "sumene               =",sumene
21992         aincr=1.0d-7
21993         xxsave=xx
21994         xx=xx+aincr
21995         write (2,*) xx,yy,zz
21996         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21997         de_dxx_num=(sumenep-sumene)/aincr
21998         xx=xxsave
21999         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22000         yysave=yy
22001         yy=yy+aincr
22002         write (2,*) xx,yy,zz
22003         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22004         de_dyy_num=(sumenep-sumene)/aincr
22005         yy=yysave
22006         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22007         zzsave=zz
22008         zz=zz+aincr
22009         write (2,*) xx,yy,zz
22010         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22011         de_dzz_num=(sumenep-sumene)/aincr
22012         zz=zzsave
22013         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22014         costsave=cost2tab(i+1)
22015         sintsave=sint2tab(i+1)
22016         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22017         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22018         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22019         de_dt_num=(sumenep-sumene)/aincr
22020         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22021         cost2tab(i+1)=costsave
22022         sint2tab(i+1)=sintsave
22023 !C End of diagnostics section.
22024 #endif
22025 !C
22026 !C Compute the gradient of esc
22027 !C
22028         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22029         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22030         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22031         de_dtt=0.0d0
22032 #ifdef DEBUG
22033         write (2,*) "x",(x(k),k=1,9)
22034         write (2,*) "xx",xx," yy",yy," zz",zz
22035         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22036           " de_zz   ",de_zz," de_tt   ",de_tt
22037         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22038           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22039 #endif
22040 !C
22041        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22042        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22043        cosfac2xx=cosfac2*xx
22044        sinfac2yy=sinfac2*yy
22045        do k = 1,3
22046          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22047            vbld_inv(i+1)
22048          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22049            vbld_inv(i)
22050          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22051          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22052 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22053 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22054 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22055 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22056          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22057          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22058          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22059          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22060          dZZ_Ci1(k)=0.0d0
22061          dZZ_Ci(k)=0.0d0
22062          do j=1,3
22063            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22064            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22065          enddo
22066
22067          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22068          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22069          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22070 !c
22071          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22072          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22073        enddo
22074
22075        do k=1,3
22076          dXX_Ctab(k,i)=dXX_Ci(k)
22077          dXX_C1tab(k,i)=dXX_Ci1(k)
22078          dYY_Ctab(k,i)=dYY_Ci(k)
22079          dYY_C1tab(k,i)=dYY_Ci1(k)
22080          dZZ_Ctab(k,i)=dZZ_Ci(k)
22081          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22082          dXX_XYZtab(k,i)=dXX_XYZ(k)
22083          dYY_XYZtab(k,i)=dYY_XYZ(k)
22084          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22085        enddo
22086        do k = 1,3
22087 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22088 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22089 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22090 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22091 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22092 !c     &    dt_dci(k)
22093 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22094 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22095          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22096          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22097          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22098          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22099          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22100          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22101 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22102        enddo
22103 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22104 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22105
22106 !C to check gradient call subroutine check_grad
22107
22108     1 continue
22109       enddo
22110       return
22111       end subroutine esb
22112 !=-------------------------------------------------------
22113       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22114 !      implicit none
22115       real(kind=8),dimension(9):: x(9)
22116        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22117       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22118       integer i
22119 !c      write (2,*) "enesc"
22120 !c      write (2,*) "x",(x(i),i=1,9)
22121 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22122       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22123         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22124         + x(9)*yy*zz
22125       enesc_nucl=sumene
22126       return
22127       end function enesc_nucl
22128 !-----------------------------------------------------------------------------
22129       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22130 #ifdef MPI
22131       include 'mpif.h'
22132       integer,parameter :: max_cont=2000
22133       integer,parameter:: max_dim=2*(8*3+6)
22134       integer, parameter :: msglen1=max_cont*max_dim
22135       integer,parameter :: msglen2=2*msglen1
22136       integer source,CorrelType,CorrelID,Error
22137       real(kind=8) :: buffer(max_cont,max_dim)
22138       integer status(MPI_STATUS_SIZE)
22139       integer :: ierror,nbytes
22140 #endif
22141       real(kind=8),dimension(3):: gx(3),gx1(3)
22142       real(kind=8) :: time00
22143       logical lprn,ldone
22144       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22145       real(kind=8) ecorr,ecorr3
22146       integer :: n_corr,n_corr1,mm,msglen
22147 !C Set lprn=.true. for debugging
22148       lprn=.false.
22149       n_corr=0
22150       n_corr1=0
22151 #ifdef MPI
22152       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22153
22154       if (nfgtasks.le.1) goto 30
22155       if (lprn) then
22156         write (iout,'(a)') 'Contact function values:'
22157         do i=nnt,nct-1
22158           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22159          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22160          j=1,num_cont_hb(i))
22161         enddo
22162       endif
22163 !C Caution! Following code assumes that electrostatic interactions concerning
22164 !C a given atom are split among at most two processors!
22165       CorrelType=477
22166       CorrelID=fg_rank+1
22167       ldone=.false.
22168       do i=1,max_cont
22169         do j=1,max_dim
22170           buffer(i,j)=0.0D0
22171         enddo
22172       enddo
22173       mm=mod(fg_rank,2)
22174 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22175       if (mm) 20,20,10
22176    10 continue
22177 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22178       if (fg_rank.gt.0) then
22179 !C Send correlation contributions to the preceding processor
22180         msglen=msglen1
22181         nn=num_cont_hb(iatel_s_nucl)
22182         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22183 !c        write (*,*) 'The BUFFER array:'
22184 !c        do i=1,nn
22185 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22186 !c        enddo
22187         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22188           msglen=msglen2
22189           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22190 !C Clear the contacts of the atom passed to the neighboring processor
22191         nn=num_cont_hb(iatel_s_nucl+1)
22192 !c        do i=1,nn
22193 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22194 !c        enddo
22195             num_cont_hb(iatel_s_nucl)=0
22196         endif
22197 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22198 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22199 !cd   & ' msglen=',msglen
22200 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22201 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22202 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22203         time00=MPI_Wtime()
22204         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22205          CorrelType,FG_COMM,IERROR)
22206         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22207 !cd      write (iout,*) 'Processor ',fg_rank,
22208 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22209 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22210 !c        write (*,*) 'Processor ',fg_rank,
22211 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22212 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22213 !c        msglen=msglen1
22214       endif ! (fg_rank.gt.0)
22215       if (ldone) goto 30
22216       ldone=.true.
22217    20 continue
22218 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22219       if (fg_rank.lt.nfgtasks-1) then
22220 !C Receive correlation contributions from the next processor
22221         msglen=msglen1
22222         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22223 !cd      write (iout,*) 'Processor',fg_rank,
22224 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22225 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22226 !c        write (*,*) 'Processor',fg_rank,
22227 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22228 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22229         time00=MPI_Wtime()
22230         nbytes=-1
22231         do while (nbytes.le.0)
22232           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22233           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22234         enddo
22235 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22236         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22237          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22238         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22239 !c        write (*,*) 'Processor',fg_rank,
22240 !c     &' has received correlation contribution from processor',fg_rank+1,
22241 !c     & ' msglen=',msglen,' nbytes=',nbytes
22242 !c        write (*,*) 'The received BUFFER array:'
22243 !c        do i=1,max_cont
22244 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22245 !c        enddo
22246         if (msglen.eq.msglen1) then
22247           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22248         else if (msglen.eq.msglen2)  then
22249           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22250           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22251         else
22252           write (iout,*) &
22253       'ERROR!!!! message length changed while processing correlations.'
22254           write (*,*) &
22255       'ERROR!!!! message length changed while processing correlations.'
22256           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22257         endif ! msglen.eq.msglen1
22258       endif ! fg_rank.lt.nfgtasks-1
22259       if (ldone) goto 30
22260       ldone=.true.
22261       goto 10
22262    30 continue
22263 #endif
22264       if (lprn) then
22265         write (iout,'(a)') 'Contact function values:'
22266         do i=nnt_molec(2),nct_molec(2)-1
22267           write (iout,'(2i3,50(1x,i2,f5.2))') &
22268          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22269          j=1,num_cont_hb(i))
22270         enddo
22271       endif
22272       ecorr=0.0D0
22273       ecorr3=0.0d0
22274 !C Remove the loop below after debugging !!!
22275 !      do i=nnt_molec(2),nct_molec(2)
22276 !        do j=1,3
22277 !          gradcorr_nucl(j,i)=0.0D0
22278 !          gradxorr_nucl(j,i)=0.0D0
22279 !          gradcorr3_nucl(j,i)=0.0D0
22280 !          gradxorr3_nucl(j,i)=0.0D0
22281 !        enddo
22282 !      enddo
22283 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22284 !C Calculate the local-electrostatic correlation terms
22285       do i=iatsc_s_nucl,iatsc_e_nucl
22286         i1=i+1
22287         num_conti=num_cont_hb(i)
22288         num_conti1=num_cont_hb(i+1)
22289 !        print *,i,num_conti,num_conti1
22290         do jj=1,num_conti
22291           j=jcont_hb(jj,i)
22292           do kk=1,num_conti1
22293             j1=jcont_hb(kk,i1)
22294 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22295 !c     &         ' jj=',jj,' kk=',kk
22296             if (j1.eq.j+1 .or. j1.eq.j-1) then
22297 !C
22298 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22299 !C The system gains extra energy.
22300 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22301 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22302 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22303 !C
22304               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22305               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22306                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22307               n_corr=n_corr+1
22308             else if (j1.eq.j) then
22309 !C
22310 !C Contacts I-J and I-(J+1) occur simultaneously.
22311 !C The system loses extra energy.
22312 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22313 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22314 !C Need to implement full formulas 32 from Liwo et al., 1998.
22315 !C
22316 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22317 !c     &         ' jj=',jj,' kk=',kk
22318               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22319             endif
22320           enddo ! kk
22321           do kk=1,num_conti
22322             j1=jcont_hb(kk,i)
22323 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22324 !c     &         ' jj=',jj,' kk=',kk
22325             if (j1.eq.j+1) then
22326 !C Contacts I-J and (I+1)-J occur simultaneously.
22327 !C The system loses extra energy.
22328               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22329             endif ! j1==j+1
22330           enddo ! kk
22331         enddo ! jj
22332       enddo ! i
22333       return
22334       end subroutine multibody_hb_nucl
22335 !-----------------------------------------------------------
22336       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22337 !      implicit real*8 (a-h,o-z)
22338 !      include 'DIMENSIONS'
22339 !      include 'COMMON.IOUNITS'
22340 !      include 'COMMON.DERIV'
22341 !      include 'COMMON.INTERACT'
22342 !      include 'COMMON.CONTACTS'
22343       real(kind=8),dimension(3) :: gx,gx1
22344       logical :: lprn
22345 !el local variables
22346       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22347       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22348                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22349                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22350                    rlocshield
22351
22352       lprn=.false.
22353       eij=facont_hb(jj,i)
22354       ekl=facont_hb(kk,k)
22355       ees0pij=ees0p(jj,i)
22356       ees0pkl=ees0p(kk,k)
22357       ees0mij=ees0m(jj,i)
22358       ees0mkl=ees0m(kk,k)
22359       ekont=eij*ekl
22360       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22361 !      print *,"ehbcorr_nucl",ekont,ees
22362 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22363 !C Following 4 lines for diagnostics.
22364 !cd    ees0pkl=0.0D0
22365 !cd    ees0pij=1.0D0
22366 !cd    ees0mkl=0.0D0
22367 !cd    ees0mij=1.0D0
22368 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22369 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22370 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22371 !C Calculate the multi-body contribution to energy.
22372 !      ecorr_nucl=ecorr_nucl+ekont*ees
22373 !C Calculate multi-body contributions to the gradient.
22374       coeffpees0pij=coeffp*ees0pij
22375       coeffmees0mij=coeffm*ees0mij
22376       coeffpees0pkl=coeffp*ees0pkl
22377       coeffmees0mkl=coeffm*ees0mkl
22378       do ll=1,3
22379         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22380        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22381        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22382         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22383         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22384         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22385         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22386         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22387         coeffmees0mij*gacontm_hb1(ll,kk,k))
22388         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22389         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22390         coeffmees0mij*gacontm_hb2(ll,kk,k))
22391         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22392           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22393           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22394         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22395         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22396         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22397           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22398           coeffmees0mij*gacontm_hb3(ll,kk,k))
22399         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22400         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22401         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22402         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22403         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22404         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22405       enddo
22406       ehbcorr_nucl=ekont*ees
22407       return
22408       end function ehbcorr_nucl
22409 !-------------------------------------------------------------------------
22410
22411      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22412 !      implicit real*8 (a-h,o-z)
22413 !      include 'DIMENSIONS'
22414 !      include 'COMMON.IOUNITS'
22415 !      include 'COMMON.DERIV'
22416 !      include 'COMMON.INTERACT'
22417 !      include 'COMMON.CONTACTS'
22418       real(kind=8),dimension(3) :: gx,gx1
22419       logical :: lprn
22420 !el local variables
22421       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22422       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22423                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22424                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22425                    rlocshield
22426
22427       lprn=.false.
22428       eij=facont_hb(jj,i)
22429       ekl=facont_hb(kk,k)
22430       ees0pij=ees0p(jj,i)
22431       ees0pkl=ees0p(kk,k)
22432       ees0mij=ees0m(jj,i)
22433       ees0mkl=ees0m(kk,k)
22434       ekont=eij*ekl
22435       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22436 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22437 !C Following 4 lines for diagnostics.
22438 !cd    ees0pkl=0.0D0
22439 !cd    ees0pij=1.0D0
22440 !cd    ees0mkl=0.0D0
22441 !cd    ees0mij=1.0D0
22442 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22443 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22444 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22445 !C Calculate the multi-body contribution to energy.
22446 !      ecorr=ecorr+ekont*ees
22447 !C Calculate multi-body contributions to the gradient.
22448       coeffpees0pij=coeffp*ees0pij
22449       coeffmees0mij=coeffm*ees0mij
22450       coeffpees0pkl=coeffp*ees0pkl
22451       coeffmees0mkl=coeffm*ees0mkl
22452       do ll=1,3
22453         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22454        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22455        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22456         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22457         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22458         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22459         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22460         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22461         coeffmees0mij*gacontm_hb1(ll,kk,k))
22462         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22463         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22464         coeffmees0mij*gacontm_hb2(ll,kk,k))
22465         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22466           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22467           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22468         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22469         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22470         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22471           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22472           coeffmees0mij*gacontm_hb3(ll,kk,k))
22473         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22474         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22475         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22476         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22477         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22478         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22479       enddo
22480       ehbcorr3_nucl=ekont*ees
22481       return
22482       end function ehbcorr3_nucl
22483 #ifdef MPI
22484       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22485       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22486       real(kind=8):: buffer(dimen1,dimen2)
22487       num_kont=num_cont_hb(atom)
22488       do i=1,num_kont
22489         do k=1,8
22490           do j=1,3
22491             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22492           enddo ! j
22493         enddo ! k
22494         buffer(i,indx+25)=facont_hb(i,atom)
22495         buffer(i,indx+26)=ees0p(i,atom)
22496         buffer(i,indx+27)=ees0m(i,atom)
22497         buffer(i,indx+28)=d_cont(i,atom)
22498         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22499       enddo ! i
22500       buffer(1,indx+30)=dfloat(num_kont)
22501       return
22502       end subroutine pack_buffer
22503 !c------------------------------------------------------------------------------
22504       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22505       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22506       real(kind=8):: buffer(dimen1,dimen2)
22507 !      double precision zapas
22508 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22509 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22510 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22511 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22512       num_kont=buffer(1,indx+30)
22513       num_kont_old=num_cont_hb(atom)
22514       num_cont_hb(atom)=num_kont+num_kont_old
22515       do i=1,num_kont
22516         ii=i+num_kont_old
22517         do k=1,8
22518           do j=1,3
22519             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22520           enddo ! j
22521         enddo ! k
22522         facont_hb(ii,atom)=buffer(i,indx+25)
22523         ees0p(ii,atom)=buffer(i,indx+26)
22524         ees0m(ii,atom)=buffer(i,indx+27)
22525         d_cont(i,atom)=buffer(i,indx+28)
22526         jcont_hb(ii,atom)=buffer(i,indx+29)
22527       enddo ! i
22528       return
22529       end subroutine unpack_buffer
22530 !c------------------------------------------------------------------------------
22531 #endif
22532       subroutine ecatcat(ecationcation)
22533         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
22534         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22535         r7,r4,ecationcation,k0,rcal
22536         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22537         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22538         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22539         gg,r
22540
22541         ecationcation=0.0d0
22542         if (nres_molec(5).eq.0) return
22543         rcat0=3.472
22544         epscalc=0.05
22545         r06 = rcat0**6
22546         r012 = r06**2
22547         k0 = 332.0*(2.0*2.0)/80.0
22548         itmp=0
22549
22550         do i=1,4
22551         itmp=itmp+nres_molec(i)
22552         enddo
22553 !        write(iout,*) "itmp",itmp
22554         do i=itmp+1,itmp+nres_molec(5)-1
22555
22556         xi=c(1,i)
22557         yi=c(2,i)
22558         zi=c(3,i)
22559
22560           xi=mod(xi,boxxsize)
22561           if (xi.lt.0) xi=xi+boxxsize
22562           yi=mod(yi,boxysize)
22563           if (yi.lt.0) yi=yi+boxysize
22564           zi=mod(zi,boxzsize)
22565           if (zi.lt.0) zi=zi+boxzsize
22566
22567           do j=i+1,itmp+nres_molec(5)
22568 !           print *,i,j,'catcat'
22569            xj=c(1,j)
22570            yj=c(2,j)
22571            zj=c(3,j)
22572           xj=dmod(xj,boxxsize)
22573           if (xj.lt.0) xj=xj+boxxsize
22574           yj=dmod(yj,boxysize)
22575           if (yj.lt.0) yj=yj+boxysize
22576           zj=dmod(zj,boxzsize)
22577           if (zj.lt.0) zj=zj+boxzsize
22578 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22579       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22580       xj_safe=xj
22581       yj_safe=yj
22582       zj_safe=zj
22583       subchap=0
22584       do xshift=-1,1
22585       do yshift=-1,1
22586       do zshift=-1,1
22587           xj=xj_safe+xshift*boxxsize
22588           yj=yj_safe+yshift*boxysize
22589           zj=zj_safe+zshift*boxzsize
22590           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22591           if(dist_temp.lt.dist_init) then
22592             dist_init=dist_temp
22593             xj_temp=xj
22594             yj_temp=yj
22595             zj_temp=zj
22596             subchap=1
22597           endif
22598        enddo
22599        enddo
22600        enddo
22601        if (subchap.eq.1) then
22602           xj=xj_temp-xi
22603           yj=yj_temp-yi
22604           zj=zj_temp-zi
22605        else
22606           xj=xj_safe-xi
22607           yj=yj_safe-yi
22608           zj=zj_safe-zi
22609        endif
22610        rcal =xj**2+yj**2+zj**2
22611         ract=sqrt(rcal)
22612 !        rcat0=3.472
22613 !        epscalc=0.05
22614 !        r06 = rcat0**6
22615 !        r012 = r06**2
22616 !        k0 = 332*(2*2)/80
22617         Evan1cat=epscalc*(r012/rcal**6)
22618         Evan2cat=epscalc*2*(r06/rcal**3)
22619         Eeleccat=k0/ract
22620         r7 = rcal**7
22621         r4 = rcal**4
22622         r(1)=xj
22623         r(2)=yj
22624         r(3)=zj
22625         do k=1,3
22626           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22627           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22628           dEeleccat(k)=-k0*r(k)/ract**3
22629         enddo
22630         do k=1,3
22631           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22632           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22633           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22634         enddo
22635
22636 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22637         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22638        enddo
22639        enddo
22640        return
22641        end subroutine ecatcat
22642 !---------------------------------------------------------------------------
22643        subroutine ecat_prot(ecation_prot)
22644        integer i,j,k,subchap,itmp,inum
22645         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22646         r7,r4,ecationcation
22647         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22648         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22649         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22650         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22651         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22652         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22653         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22654         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22655         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22656         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22657         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
22658         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22659         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22660         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22661         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22662         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22663         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22664         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22665         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22666         dEvan1Cat
22667         real(kind=8),dimension(6) :: vcatprm
22668         ecation_prot=0.0d0
22669 ! first lets calculate interaction with peptide groups
22670         if (nres_molec(5).eq.0) return
22671          wconst=78
22672         wdip =1.092777950857032D2
22673         wdip=wdip/wconst
22674         wmodquad=-2.174122713004870D4
22675         wmodquad=wmodquad/wconst
22676         wquad1 = 3.901232068562804D1
22677         wquad1=wquad1/wconst
22678         wquad2 = 3
22679         wquad2=wquad2/wconst
22680         wvan1 = 0.1
22681         wvan2 = 6
22682         itmp=0
22683         do i=1,4
22684         itmp=itmp+nres_molec(i)
22685         enddo
22686 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22687         do i=ibond_start,ibond_end
22688 !         cycle
22689          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22690         xi=0.5d0*(c(1,i)+c(1,i+1))
22691         yi=0.5d0*(c(2,i)+c(2,i+1))
22692         zi=0.5d0*(c(3,i)+c(3,i+1))
22693           xi=mod(xi,boxxsize)
22694           if (xi.lt.0) xi=xi+boxxsize
22695           yi=mod(yi,boxysize)
22696           if (yi.lt.0) yi=yi+boxysize
22697           zi=mod(zi,boxzsize)
22698           if (zi.lt.0) zi=zi+boxzsize
22699
22700          do j=itmp+1,itmp+nres_molec(5)
22701            xj=c(1,j)
22702            yj=c(2,j)
22703            zj=c(3,j)
22704           xj=dmod(xj,boxxsize)
22705           if (xj.lt.0) xj=xj+boxxsize
22706           yj=dmod(yj,boxysize)
22707           if (yj.lt.0) yj=yj+boxysize
22708           zj=dmod(zj,boxzsize)
22709           if (zj.lt.0) zj=zj+boxzsize
22710       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22711       xj_safe=xj
22712       yj_safe=yj
22713       zj_safe=zj
22714       subchap=0
22715       do xshift=-1,1
22716       do yshift=-1,1
22717       do zshift=-1,1
22718           xj=xj_safe+xshift*boxxsize
22719           yj=yj_safe+yshift*boxysize
22720           zj=zj_safe+zshift*boxzsize
22721           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22722           if(dist_temp.lt.dist_init) then
22723             dist_init=dist_temp
22724             xj_temp=xj
22725             yj_temp=yj
22726             zj_temp=zj
22727             subchap=1
22728           endif
22729        enddo
22730        enddo
22731        enddo
22732        if (subchap.eq.1) then
22733           xj=xj_temp-xi
22734           yj=yj_temp-yi
22735           zj=zj_temp-zi
22736        else
22737           xj=xj_safe-xi
22738           yj=yj_safe-yi
22739           zj=zj_safe-zi
22740        endif
22741 !       enddo
22742 !       enddo
22743        rcpm = sqrt(xj**2+yj**2+zj**2)
22744        drcp_norm(1)=xj/rcpm
22745        drcp_norm(2)=yj/rcpm
22746        drcp_norm(3)=zj/rcpm
22747        dcmag=0.0
22748        do k=1,3
22749        dcmag=dcmag+dc(k,i)**2
22750        enddo
22751        dcmag=dsqrt(dcmag)
22752        do k=1,3
22753          myd_norm(k)=dc(k,i)/dcmag
22754        enddo
22755         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22756         drcp_norm(3)*myd_norm(3)
22757         rsecp = rcpm**2
22758         Ir = 1.0d0/rcpm
22759         Irsecp = 1.0d0/rsecp
22760         Irthrp = Irsecp/rcpm
22761         Irfourp = Irthrp/rcpm
22762         Irfiftp = Irfourp/rcpm
22763         Irsistp=Irfiftp/rcpm
22764         Irseven=Irsistp/rcpm
22765         Irtwelv=Irsistp*Irsistp
22766         Irthir=Irtwelv/rcpm
22767         sin2thet = (1-costhet*costhet)
22768         sinthet=sqrt(sin2thet)
22769         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22770              *sin2thet
22771         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22772              2*wvan2**6*Irsistp)
22773         ecation_prot = ecation_prot+E1+E2
22774         dE1dr = -2*costhet*wdip*Irthrp-&
22775          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22776         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22777           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22778         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22779         do k=1,3
22780           drdpep(k) = -drcp_norm(k)
22781           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22782           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22783           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22784           dEddci(k) = dEdcos*dcosddci(k)
22785         enddo
22786         do k=1,3
22787         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22788         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22789         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22790         enddo
22791        enddo ! j
22792        enddo ! i
22793 !------------------------------------------sidechains
22794 !        do i=1,nres_molec(1)
22795         do i=ibond_start,ibond_end
22796          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22797 !         cycle
22798 !        print *,i,ecation_prot
22799         xi=(c(1,i+nres))
22800         yi=(c(2,i+nres))
22801         zi=(c(3,i+nres))
22802           xi=mod(xi,boxxsize)
22803           if (xi.lt.0) xi=xi+boxxsize
22804           yi=mod(yi,boxysize)
22805           if (yi.lt.0) yi=yi+boxysize
22806           zi=mod(zi,boxzsize)
22807           if (zi.lt.0) zi=zi+boxzsize
22808           do k=1,3
22809             cm1(k)=dc(k,i+nres)
22810           enddo
22811            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22812          do j=itmp+1,itmp+nres_molec(5)
22813            xj=c(1,j)
22814            yj=c(2,j)
22815            zj=c(3,j)
22816           xj=dmod(xj,boxxsize)
22817           if (xj.lt.0) xj=xj+boxxsize
22818           yj=dmod(yj,boxysize)
22819           if (yj.lt.0) yj=yj+boxysize
22820           zj=dmod(zj,boxzsize)
22821           if (zj.lt.0) zj=zj+boxzsize
22822       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22823       xj_safe=xj
22824       yj_safe=yj
22825       zj_safe=zj
22826       subchap=0
22827       do xshift=-1,1
22828       do yshift=-1,1
22829       do zshift=-1,1
22830           xj=xj_safe+xshift*boxxsize
22831           yj=yj_safe+yshift*boxysize
22832           zj=zj_safe+zshift*boxzsize
22833           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22834           if(dist_temp.lt.dist_init) then
22835             dist_init=dist_temp
22836             xj_temp=xj
22837             yj_temp=yj
22838             zj_temp=zj
22839             subchap=1
22840           endif
22841        enddo
22842        enddo
22843        enddo
22844        if (subchap.eq.1) then
22845           xj=xj_temp-xi
22846           yj=yj_temp-yi
22847           zj=zj_temp-zi
22848        else
22849           xj=xj_safe-xi
22850           yj=yj_safe-yi
22851           zj=zj_safe-zi
22852        endif
22853 !       enddo
22854 !       enddo
22855          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22856             if(itype(i,1).eq.16) then
22857             inum=1
22858             else
22859             inum=2
22860             endif
22861             do k=1,6
22862             vcatprm(k)=catprm(k,inum)
22863             enddo
22864             dASGL=catprm(7,inum)
22865 !             do k=1,3
22866 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22867                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
22868                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
22869                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
22870
22871 !                valpha(k)=c(k,i)
22872 !                vcat(k)=c(k,j)
22873                 if (subchap.eq.1) then
22874                  vcat(1)=xj_temp
22875                  vcat(2)=yj_temp
22876                  vcat(3)=zj_temp
22877                  else
22878                 vcat(1)=xj_safe
22879                 vcat(2)=yj_safe
22880                 vcat(3)=zj_safe
22881                  endif
22882                 valpha(1)=xi-c(1,i+nres)+c(1,i)
22883                 valpha(2)=yi-c(2,i+nres)+c(2,i)
22884                 valpha(3)=zi-c(3,i+nres)+c(3,i)
22885
22886 !              enddo
22887         do k=1,3
22888           dx(k) = vcat(k)-vcm(k)
22889         enddo
22890         do k=1,3
22891           v1(k)=(vcm(k)-valpha(k))
22892           v2(k)=(vcat(k)-valpha(k))
22893         enddo
22894         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22895         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22896         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22897
22898 !  The weights of the energy function calculated from
22899 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22900         wh2o=78
22901         wc = vcatprm(1)
22902         wc=wc/wh2o
22903         wdip =vcatprm(2)
22904         wdip=wdip/wh2o
22905         wquad1 =vcatprm(3)
22906         wquad1=wquad1/wh2o
22907         wquad2 = vcatprm(4)
22908         wquad2=wquad2/wh2o
22909         wquad2p = 1.0d0-wquad2
22910         wvan1 = vcatprm(5)
22911         wvan2 =vcatprm(6)
22912         opt = dx(1)**2+dx(2)**2
22913         rsecp = opt+dx(3)**2
22914         rs = sqrt(rsecp)
22915         rthrp = rsecp*rs
22916         rfourp = rthrp*rs
22917         rsixp = rfourp*rsecp
22918         reight=rsixp*rsecp
22919         Ir = 1.0d0/rs
22920         Irsecp = 1.0d0/rsecp
22921         Irthrp = Irsecp/rs
22922         Irfourp = Irthrp/rs
22923         Irsixp = 1.0d0/rsixp
22924         Ireight=1.0d0/reight
22925         Irtw=Irsixp*Irsixp
22926         Irthir=Irtw/rs
22927         Irfourt=Irthir/rs
22928         opt1 = (4*rs*dx(3)*wdip)
22929         opt2 = 6*rsecp*wquad1*opt
22930         opt3 = wquad1*wquad2p*Irsixp
22931         opt4 = (wvan1*wvan2**12)
22932         opt5 = opt4*12*Irfourt
22933         opt6 = 2*wvan1*wvan2**6
22934         opt7 = 6*opt6*Ireight
22935         opt8 = wdip/v1m
22936         opt10 = wdip/v2m
22937         opt11 = (rsecp*v2m)**2
22938         opt12 = (rsecp*v1m)**2
22939         opt14 = (v1m*v2m*rsecp)**2
22940         opt15 = -wquad1/v2m**2
22941         opt16 = (rthrp*(v1m*v2m)**2)**2
22942         opt17 = (v1m**2*rthrp)**2
22943         opt18 = -wquad1/rthrp
22944         opt19 = (v1m**2*v2m**2)**2
22945         Ec = wc*Ir
22946         do k=1,3
22947           dEcCat(k) = -(dx(k)*wc)*Irthrp
22948           dEcCm(k)=(dx(k)*wc)*Irthrp
22949           dEcCalp(k)=0.0d0
22950         enddo
22951         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22952         do k=1,3
22953           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22954                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22955           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22956                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22957           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22958                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22959                       *v1dpv2)/opt14
22960         enddo
22961         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22962         do k=1,3
22963           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22964                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22965                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22966           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22967                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22968                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22969           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22970                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22971                         v1dpv2**2)/opt19
22972         enddo
22973         Equad2=wquad1*wquad2p*Irthrp
22974         do k=1,3
22975           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22976           dEquad2Cm(k)=3*dx(k)*rs*opt3
22977           dEquad2Calp(k)=0.0d0
22978         enddo
22979         Evan1=opt4*Irtw
22980         do k=1,3
22981           dEvan1Cat(k)=-dx(k)*opt5
22982           dEvan1Cm(k)=dx(k)*opt5
22983           dEvan1Calp(k)=0.0d0
22984         enddo
22985         Evan2=-opt6*Irsixp
22986         do k=1,3
22987           dEvan2Cat(k)=dx(k)*opt7
22988           dEvan2Cm(k)=-dx(k)*opt7
22989           dEvan2Calp(k)=0.0d0
22990         enddo
22991         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22992 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22993
22994         do k=1,3
22995           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22996                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22997 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22998           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22999                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23000           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23001                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23002         enddo
23003             dscmag = 0.0d0
23004             do k=1,3
23005               dscvec(k) = dc(k,i+nres)
23006               dscmag = dscmag+dscvec(k)*dscvec(k)
23007             enddo
23008             dscmag3 = dscmag
23009             dscmag = sqrt(dscmag)
23010             dscmag3 = dscmag3*dscmag
23011             constA = 1.0d0+dASGL/dscmag
23012             constB = 0.0d0
23013             do k=1,3
23014               constB = constB+dscvec(k)*dEtotalCm(k)
23015             enddo
23016             constB = constB*dASGL/dscmag3
23017             do k=1,3
23018               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23019               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23020                constA*dEtotalCm(k)-constB*dscvec(k)
23021 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23022               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23023               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23024              enddo
23025         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23026            if(itype(i,1).eq.14) then
23027             inum=3
23028             else
23029             inum=4
23030             endif
23031             do k=1,6
23032             vcatprm(k)=catprm(k,inum)
23033             enddo
23034             dASGL=catprm(7,inum)
23035 !             do k=1,3
23036 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23037 !                valpha(k)=c(k,i)
23038 !                vcat(k)=c(k,j)
23039 !              enddo
23040                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23041                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23042                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23043                 if (subchap.eq.1) then
23044                  vcat(1)=xj_temp
23045                  vcat(2)=yj_temp
23046                  vcat(3)=zj_temp
23047                  else
23048                 vcat(1)=xj_safe
23049                 vcat(2)=yj_safe
23050                 vcat(3)=zj_safe
23051                 endif
23052                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23053                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23054                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23055
23056
23057         do k=1,3
23058           dx(k) = vcat(k)-vcm(k)
23059         enddo
23060         do k=1,3
23061           v1(k)=(vcm(k)-valpha(k))
23062           v2(k)=(vcat(k)-valpha(k))
23063         enddo
23064         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23065         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23066         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23067 !  The weights of the energy function calculated from
23068 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23069         wh2o=78
23070         wdip =vcatprm(2)
23071         wdip=wdip/wh2o
23072         wquad1 =vcatprm(3)
23073         wquad1=wquad1/wh2o
23074         wquad2 = vcatprm(4)
23075         wquad2=wquad2/wh2o
23076         wquad2p = 1-wquad2
23077         wvan1 = vcatprm(5)
23078         wvan2 =vcatprm(6)
23079         opt = dx(1)**2+dx(2)**2
23080         rsecp = opt+dx(3)**2
23081         rs = sqrt(rsecp)
23082         rthrp = rsecp*rs
23083         rfourp = rthrp*rs
23084         rsixp = rfourp*rsecp
23085         reight=rsixp*rsecp
23086         Ir = 1.0d0/rs
23087         Irsecp = 1/rsecp
23088         Irthrp = Irsecp/rs
23089         Irfourp = Irthrp/rs
23090         Irsixp = 1/rsixp
23091         Ireight=1/reight
23092         Irtw=Irsixp*Irsixp
23093         Irthir=Irtw/rs
23094         Irfourt=Irthir/rs
23095         opt1 = (4*rs*dx(3)*wdip)
23096         opt2 = 6*rsecp*wquad1*opt
23097         opt3 = wquad1*wquad2p*Irsixp
23098         opt4 = (wvan1*wvan2**12)
23099         opt5 = opt4*12*Irfourt
23100         opt6 = 2*wvan1*wvan2**6
23101         opt7 = 6*opt6*Ireight
23102         opt8 = wdip/v1m
23103         opt10 = wdip/v2m
23104         opt11 = (rsecp*v2m)**2
23105         opt12 = (rsecp*v1m)**2
23106         opt14 = (v1m*v2m*rsecp)**2
23107         opt15 = -wquad1/v2m**2
23108         opt16 = (rthrp*(v1m*v2m)**2)**2
23109         opt17 = (v1m**2*rthrp)**2
23110         opt18 = -wquad1/rthrp
23111         opt19 = (v1m**2*v2m**2)**2
23112         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23113         do k=1,3
23114           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23115                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23116          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23117                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23118           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23119                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23120                       *v1dpv2)/opt14
23121         enddo
23122         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23123         do k=1,3
23124           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23125                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23126                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23127           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23128                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23129                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23130           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23131                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23132                         v1dpv2**2)/opt19
23133         enddo
23134         Equad2=wquad1*wquad2p*Irthrp
23135         do k=1,3
23136           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23137           dEquad2Cm(k)=3*dx(k)*rs*opt3
23138           dEquad2Calp(k)=0.0d0
23139         enddo
23140         Evan1=opt4*Irtw
23141         do k=1,3
23142           dEvan1Cat(k)=-dx(k)*opt5
23143           dEvan1Cm(k)=dx(k)*opt5
23144           dEvan1Calp(k)=0.0d0
23145         enddo
23146         Evan2=-opt6*Irsixp
23147         do k=1,3
23148           dEvan2Cat(k)=dx(k)*opt7
23149           dEvan2Cm(k)=-dx(k)*opt7
23150           dEvan2Calp(k)=0.0d0
23151         enddo
23152          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23153         do k=1,3
23154           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23155                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23156           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23157                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23158           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23159                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23160         enddo
23161             dscmag = 0.0d0
23162             do k=1,3
23163               dscvec(k) = c(k,i+nres)-c(k,i)
23164 ! TU SPRAWDZ???
23165 !              dscvec(1) = xj
23166 !              dscvec(2) = yj
23167 !              dscvec(3) = zj
23168
23169               dscmag = dscmag+dscvec(k)*dscvec(k)
23170             enddo
23171             dscmag3 = dscmag
23172             dscmag = sqrt(dscmag)
23173             dscmag3 = dscmag3*dscmag
23174             constA = 1+dASGL/dscmag
23175             constB = 0.0d0
23176             do k=1,3
23177               constB = constB+dscvec(k)*dEtotalCm(k)
23178             enddo
23179             constB = constB*dASGL/dscmag3
23180             do k=1,3
23181               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23182               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23183                constA*dEtotalCm(k)-constB*dscvec(k)
23184               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23185               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23186              enddo
23187            else
23188             rcal = 0.0d0
23189             do k=1,3
23190 !              r(k) = c(k,j)-c(k,i+nres)
23191               r(1) = xj
23192               r(2) = yj
23193               r(3) = zj
23194               rcal = rcal+r(k)*r(k)
23195             enddo
23196             ract=sqrt(rcal)
23197             rocal=1.5
23198             epscalc=0.2
23199             r0p=0.5*(rocal+sig0(itype(i,1)))
23200             r06 = r0p**6
23201             r012 = r06*r06
23202             Evan1=epscalc*(r012/rcal**6)
23203             Evan2=epscalc*2*(r06/rcal**3)
23204             r4 = rcal**4
23205             r7 = rcal**7
23206             do k=1,3
23207               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23208               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23209             enddo
23210             do k=1,3
23211               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23212             enddo
23213                  ecation_prot = ecation_prot+ Evan1+Evan2
23214             do  k=1,3
23215                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23216                dEtotalCm(k)
23217               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23218               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23219              enddo
23220          endif ! 13-16 residues
23221        enddo !j
23222        enddo !i
23223        return
23224        end subroutine ecat_prot
23225
23226 !----------------------------------------------------------------------------
23227 !-----------------------------------------------------------------------------
23228 !-----------------------------------------------------------------------------
23229       subroutine eprot_sc_base(escbase)
23230       use calc_data
23231 !      implicit real*8 (a-h,o-z)
23232 !      include 'DIMENSIONS'
23233 !      include 'COMMON.GEO'
23234 !      include 'COMMON.VAR'
23235 !      include 'COMMON.LOCAL'
23236 !      include 'COMMON.CHAIN'
23237 !      include 'COMMON.DERIV'
23238 !      include 'COMMON.NAMES'
23239 !      include 'COMMON.INTERACT'
23240 !      include 'COMMON.IOUNITS'
23241 !      include 'COMMON.CALC'
23242 !      include 'COMMON.CONTROL'
23243 !      include 'COMMON.SBRIDGE'
23244       logical :: lprn
23245 !el local variables
23246       integer :: iint,itypi,itypi1,itypj,subchap
23247       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23248       real(kind=8) :: evdw,sig0ij
23249       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23250                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23251                     sslipi,sslipj,faclip
23252       integer :: ii
23253       real(kind=8) :: fracinbuf
23254        real (kind=8) :: escbase
23255        real (kind=8),dimension(4):: ener
23256        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23257        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23258         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23259         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23260         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23261         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23262         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23263         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23264        real(kind=8),dimension(3,2)::chead,erhead_tail
23265        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23266        integer troll
23267        eps_out=80.0d0
23268        escbase=0.0d0
23269 !       do i=1,nres_molec(1)
23270         do i=ibond_start,ibond_end
23271         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23272         itypi  = itype(i,1)
23273         dxi    = dc_norm(1,nres+i)
23274         dyi    = dc_norm(2,nres+i)
23275         dzi    = dc_norm(3,nres+i)
23276         dsci_inv = vbld_inv(i+nres)
23277         xi=c(1,nres+i)
23278         yi=c(2,nres+i)
23279         zi=c(3,nres+i)
23280         xi=mod(xi,boxxsize)
23281          if (xi.lt.0) xi=xi+boxxsize
23282         yi=mod(yi,boxysize)
23283          if (yi.lt.0) yi=yi+boxysize
23284         zi=mod(zi,boxzsize)
23285          if (zi.lt.0) zi=zi+boxzsize
23286          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23287            itypj= itype(j,2)
23288            if (itype(j,2).eq.ntyp1_molec(2))cycle
23289            xj=c(1,j+nres)
23290            yj=c(2,j+nres)
23291            zj=c(3,j+nres)
23292            xj=dmod(xj,boxxsize)
23293            if (xj.lt.0) xj=xj+boxxsize
23294            yj=dmod(yj,boxysize)
23295            if (yj.lt.0) yj=yj+boxysize
23296            zj=dmod(zj,boxzsize)
23297            if (zj.lt.0) zj=zj+boxzsize
23298           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23299           xj_safe=xj
23300           yj_safe=yj
23301           zj_safe=zj
23302           subchap=0
23303
23304           do xshift=-1,1
23305           do yshift=-1,1
23306           do zshift=-1,1
23307           xj=xj_safe+xshift*boxxsize
23308           yj=yj_safe+yshift*boxysize
23309           zj=zj_safe+zshift*boxzsize
23310           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23311           if(dist_temp.lt.dist_init) then
23312             dist_init=dist_temp
23313             xj_temp=xj
23314             yj_temp=yj
23315             zj_temp=zj
23316             subchap=1
23317           endif
23318           enddo
23319           enddo
23320           enddo
23321           if (subchap.eq.1) then
23322           xj=xj_temp-xi
23323           yj=yj_temp-yi
23324           zj=zj_temp-zi
23325           else
23326           xj=xj_safe-xi
23327           yj=yj_safe-yi
23328           zj=zj_safe-zi
23329           endif
23330           dxj = dc_norm( 1, nres+j )
23331           dyj = dc_norm( 2, nres+j )
23332           dzj = dc_norm( 3, nres+j )
23333 !          print *,i,j,itypi,itypj
23334           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23335           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23336 !          d1i=0.0d0
23337 !          d1j=0.0d0
23338 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23339 ! Gay-berne var's
23340           sig0ij = sigma_scbase( itypi,itypj )
23341           chi1   = chi_scbase( itypi, itypj,1 )
23342           chi2   = chi_scbase( itypi, itypj,2 )
23343 !          chi1=0.0d0
23344 !          chi2=0.0d0
23345           chi12  = chi1 * chi2
23346           chip1  = chipp_scbase( itypi, itypj,1 )
23347           chip2  = chipp_scbase( itypi, itypj,2 )
23348 !          chip1=0.0d0
23349 !          chip2=0.0d0
23350           chip12 = chip1 * chip2
23351 ! not used by momo potential, but needed by sc_angular which is shared
23352 ! by all energy_potential subroutines
23353           alf1   = 0.0d0
23354           alf2   = 0.0d0
23355           alf12  = 0.0d0
23356           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23357 !       a12sq = a12sq * a12sq
23358 ! charge of amino acid itypi is...
23359           chis1 = chis_scbase(itypi,itypj,1)
23360           chis2 = chis_scbase(itypi,itypj,2)
23361           chis12 = chis1 * chis2
23362           sig1 = sigmap1_scbase(itypi,itypj)
23363           sig2 = sigmap2_scbase(itypi,itypj)
23364 !       write (*,*) "sig1 = ", sig1
23365 !       write (*,*) "sig2 = ", sig2
23366 ! alpha factors from Fcav/Gcav
23367           b1 = alphasur_scbase(1,itypi,itypj)
23368 !          b1=0.0d0
23369           b2 = alphasur_scbase(2,itypi,itypj)
23370           b3 = alphasur_scbase(3,itypi,itypj)
23371           b4 = alphasur_scbase(4,itypi,itypj)
23372 ! used to determine whether we want to do quadrupole calculations
23373 ! used by Fgb
23374        eps_in = epsintab_scbase(itypi,itypj)
23375        if (eps_in.eq.0.0) eps_in=1.0
23376        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23377 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23378 !-------------------------------------------------------------------
23379 ! tail location and distance calculations
23380        DO k = 1,3
23381 ! location of polar head is computed by taking hydrophobic centre
23382 ! and moving by a d1 * dc_norm vector
23383 ! see unres publications for very informative images
23384         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23385         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23386 ! distance
23387 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23388 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23389         Rhead_distance(k) = chead(k,2) - chead(k,1)
23390        END DO
23391 ! pitagoras (root of sum of squares)
23392        Rhead = dsqrt( &
23393           (Rhead_distance(1)*Rhead_distance(1)) &
23394         + (Rhead_distance(2)*Rhead_distance(2)) &
23395         + (Rhead_distance(3)*Rhead_distance(3)))
23396 !-------------------------------------------------------------------
23397 ! zero everything that should be zero'ed
23398        evdwij = 0.0d0
23399        ECL = 0.0d0
23400        Elj = 0.0d0
23401        Equad = 0.0d0
23402        Epol = 0.0d0
23403        Fcav=0.0d0
23404        eheadtail = 0.0d0
23405        dGCLdOM1 = 0.0d0
23406        dGCLdOM2 = 0.0d0
23407        dGCLdOM12 = 0.0d0
23408        dPOLdOM1 = 0.0d0
23409        dPOLdOM2 = 0.0d0
23410           Fcav = 0.0d0
23411           dFdR = 0.0d0
23412           dCAVdOM1  = 0.0d0
23413           dCAVdOM2  = 0.0d0
23414           dCAVdOM12 = 0.0d0
23415           dscj_inv = vbld_inv(j+nres)
23416 !          print *,i,j,dscj_inv,dsci_inv
23417 ! rij holds 1/(distance of Calpha atoms)
23418           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23419           rij  = dsqrt(rrij)
23420 !----------------------------
23421           CALL sc_angular
23422 ! this should be in elgrad_init but om's are calculated by sc_angular
23423 ! which in turn is used by older potentials
23424 ! om = omega, sqom = om^2
23425           sqom1  = om1 * om1
23426           sqom2  = om2 * om2
23427           sqom12 = om12 * om12
23428
23429 ! now we calculate EGB - Gey-Berne
23430 ! It will be summed up in evdwij and saved in evdw
23431           sigsq     = 1.0D0  / sigsq
23432           sig       = sig0ij * dsqrt(sigsq)
23433 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23434           rij_shift = 1.0/rij - sig + sig0ij
23435           IF (rij_shift.le.0.0D0) THEN
23436            evdw = 1.0D20
23437            RETURN
23438           END IF
23439           sigder = -sig * sigsq
23440           rij_shift = 1.0D0 / rij_shift
23441           fac       = rij_shift**expon
23442           c1        = fac  * fac * aa_scbase(itypi,itypj)
23443 !          c1        = 0.0d0
23444           c2        = fac  * bb_scbase(itypi,itypj)
23445 !          c2        = 0.0d0
23446           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23447           eps2der   = eps3rt * evdwij
23448           eps3der   = eps2rt * evdwij
23449 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23450           evdwij    = eps2rt * eps3rt * evdwij
23451           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23452           fac    = -expon * (c1 + evdwij) * rij_shift
23453           sigder = fac * sigder
23454 !          fac    = rij * fac
23455 ! Calculate distance derivative
23456           gg(1) =  fac
23457           gg(2) =  fac
23458           gg(3) =  fac
23459 !          if (b2.gt.0.0) then
23460           fac = chis1 * sqom1 + chis2 * sqom2 &
23461           - 2.0d0 * chis12 * om1 * om2 * om12
23462 ! we will use pom later in Gcav, so dont mess with it!
23463           pom = 1.0d0 - chis1 * chis2 * sqom12
23464           Lambf = (1.0d0 - (fac / pom))
23465           Lambf = dsqrt(Lambf)
23466           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23467 !       write (*,*) "sparrow = ", sparrow
23468           Chif = 1.0d0/rij * sparrow
23469           ChiLambf = Chif * Lambf
23470           eagle = dsqrt(ChiLambf)
23471           bat = ChiLambf ** 11.0d0
23472           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23473           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23474           botsq = bot * bot
23475           Fcav = top / bot
23476 !          print *,i,j,Fcav
23477           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23478           dbot = 12.0d0 * b4 * bat * Lambf
23479           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23480 !       dFdR = 0.0d0
23481 !      write (*,*) "dFcav/dR = ", dFdR
23482           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23483           dbot = 12.0d0 * b4 * bat * Chif
23484           eagle = Lambf * pom
23485           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23486           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23487           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23488               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23489
23490           dFdL = ((dtop * bot - top * dbot) / botsq)
23491 !       dFdL = 0.0d0
23492           dCAVdOM1  = dFdL * ( dFdOM1 )
23493           dCAVdOM2  = dFdL * ( dFdOM2 )
23494           dCAVdOM12 = dFdL * ( dFdOM12 )
23495
23496           ertail(1) = xj*rij
23497           ertail(2) = yj*rij
23498           ertail(3) = zj*rij
23499 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23500 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23501 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23502 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23503 !           print *,"EOMY",eom1,eom2,eom12
23504 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23505 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23506 ! here dtail=0.0
23507 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23508 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23509        DO k = 1, 3
23510 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23511 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23512         pom = ertail(k)
23513 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23514         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23515                   - (( dFdR + gg(k) ) * pom)
23516 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23517 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23518 !     &             - ( dFdR * pom )
23519         pom = ertail(k)
23520 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23521         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23522                   + (( dFdR + gg(k) ) * pom)
23523 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23524 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23525 !c!     &             + ( dFdR * pom )
23526
23527         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23528                   - (( dFdR + gg(k) ) * ertail(k))
23529 !c!     &             - ( dFdR * ertail(k))
23530
23531         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23532                   + (( dFdR + gg(k) ) * ertail(k))
23533 !c!     &             + ( dFdR * ertail(k))
23534
23535         gg(k) = 0.0d0
23536 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23537 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23538       END DO
23539
23540 !          else
23541
23542 !          endif
23543 !Now dipole-dipole
23544          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23545        w1 = wdipdip_scbase(1,itypi,itypj)
23546        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23547        w3 = wdipdip_scbase(2,itypi,itypj)
23548 !c!-------------------------------------------------------------------
23549 !c! ECL
23550        fac = (om12 - 3.0d0 * om1 * om2)
23551        c1 = (w1 / (Rhead**3.0d0)) * fac
23552        c2 = (w2 / Rhead ** 6.0d0)  &
23553          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23554        c3= (w3/ Rhead ** 6.0d0)  &
23555          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23556        ECL = c1 - c2 + c3
23557 !c!       write (*,*) "w1 = ", w1
23558 !c!       write (*,*) "w2 = ", w2
23559 !c!       write (*,*) "om1 = ", om1
23560 !c!       write (*,*) "om2 = ", om2
23561 !c!       write (*,*) "om12 = ", om12
23562 !c!       write (*,*) "fac = ", fac
23563 !c!       write (*,*) "c1 = ", c1
23564 !c!       write (*,*) "c2 = ", c2
23565 !c!       write (*,*) "Ecl = ", Ecl
23566 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23567 !c!       write (*,*) "c2_2 = ",
23568 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23569 !c!-------------------------------------------------------------------
23570 !c! dervative of ECL is GCL...
23571 !c! dECL/dr
23572        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23573        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23574          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23575        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23576          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23577        dGCLdR = c1 - c2 + c3
23578 !c! dECL/dom1
23579        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23580        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23581          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23582        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23583        dGCLdOM1 = c1 - c2 + c3
23584 !c! dECL/dom2
23585        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23586        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23587          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23588        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23589        dGCLdOM2 = c1 - c2 + c3
23590 !c! dECL/dom12
23591        c1 = w1 / (Rhead ** 3.0d0)
23592        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23593        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23594        dGCLdOM12 = c1 - c2 + c3
23595        DO k= 1, 3
23596         erhead(k) = Rhead_distance(k)/Rhead
23597        END DO
23598        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23599        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23600        facd1 = d1i * vbld_inv(i+nres)
23601        facd2 = d1j * vbld_inv(j+nres)
23602        DO k = 1, 3
23603
23604         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23605         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23606                   - dGCLdR * pom
23607         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23608         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23609                   + dGCLdR * pom
23610
23611         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23612                   - dGCLdR * erhead(k)
23613         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23614                   + dGCLdR * erhead(k)
23615        END DO
23616        endif
23617 !now charge with dipole eg. ARG-dG
23618        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23619       alphapol1 = alphapol_scbase(itypi,itypj)
23620        w1        = wqdip_scbase(1,itypi,itypj)
23621        w2        = wqdip_scbase(2,itypi,itypj)
23622 !       w1=0.0d0
23623 !       w2=0.0d0
23624 !       pis       = sig0head_scbase(itypi,itypj)
23625 !       eps_head   = epshead_scbase(itypi,itypj)
23626 !c!-------------------------------------------------------------------
23627 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23628        R1 = 0.0d0
23629        DO k = 1, 3
23630 !c! Calculate head-to-tail distances tail is center of side-chain
23631         R1=R1+(c(k,j+nres)-chead(k,1))**2
23632        END DO
23633 !c! Pitagoras
23634        R1 = dsqrt(R1)
23635
23636 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23637 !c!     &        +dhead(1,1,itypi,itypj))**2))
23638 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23639 !c!     &        +dhead(2,1,itypi,itypj))**2))
23640
23641 !c!-------------------------------------------------------------------
23642 !c! ecl
23643        sparrow  = w1  *  om1
23644        hawk     = w2 *  (1.0d0 - sqom2)
23645        Ecl = sparrow / Rhead**2.0d0 &
23646            - hawk    / Rhead**4.0d0
23647 !c!-------------------------------------------------------------------
23648 !c! derivative of ecl is Gcl
23649 !c! dF/dr part
23650        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23651                 + 4.0d0 * hawk    / Rhead**5.0d0
23652 !c! dF/dom1
23653        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23654 !c! dF/dom2
23655        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23656 !c--------------------------------------------------------------------
23657 !c Polarization energy
23658 !c Epol
23659        MomoFac1 = (1.0d0 - chi1 * sqom2)
23660        RR1  = R1 * R1 / MomoFac1
23661        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23662        fgb1 = sqrt( RR1 + a12sq * ee1)
23663 !       eps_inout_fac=0.0d0
23664        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23665 ! derivative of Epol is Gpol...
23666        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23667                 / (fgb1 ** 5.0d0)
23668        dFGBdR1 = ( (R1 / MomoFac1) &
23669              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23670              / ( 2.0d0 * fgb1 )
23671        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23672                * (2.0d0 - 0.5d0 * ee1) ) &
23673                / (2.0d0 * fgb1)
23674        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23675 !       dPOLdR1 = 0.0d0
23676        dPOLdOM1 = 0.0d0
23677        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23678        DO k = 1, 3
23679         erhead(k) = Rhead_distance(k)/Rhead
23680         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23681        END DO
23682
23683        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23684        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23685        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23686 !       bat=0.0d0
23687        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23688        facd1 = d1i * vbld_inv(i+nres)
23689        facd2 = d1j * vbld_inv(j+nres)
23690 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23691
23692        DO k = 1, 3
23693         hawk = (erhead_tail(k,1) + &
23694         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23695 !        facd1=0.0d0
23696 !        facd2=0.0d0
23697         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23698         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23699                    - dGCLdR * pom &
23700                    - dPOLdR1 *  (erhead_tail(k,1))
23701 !     &             - dGLJdR * pom
23702
23703         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23704         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23705                    + dGCLdR * pom  &
23706                    + dPOLdR1 * (erhead_tail(k,1))
23707 !     &             + dGLJdR * pom
23708
23709
23710         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23711                   - dGCLdR * erhead(k) &
23712                   - dPOLdR1 * erhead_tail(k,1)
23713 !     &             - dGLJdR * erhead(k)
23714
23715         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23716                   + dGCLdR * erhead(k)  &
23717                   + dPOLdR1 * erhead_tail(k,1)
23718 !     &             + dGLJdR * erhead(k)
23719
23720        END DO
23721        endif
23722 !       print *,i,j,evdwij,epol,Fcav,ECL
23723        escbase=escbase+evdwij+epol+Fcav+ECL
23724        call sc_grad_scbase
23725          enddo
23726       enddo
23727
23728       return
23729       end subroutine eprot_sc_base
23730       SUBROUTINE sc_grad_scbase
23731       use calc_data
23732
23733        real (kind=8) :: dcosom1(3),dcosom2(3)
23734        eom1  =    &
23735               eps2der * eps2rt_om1   &
23736             - 2.0D0 * alf1 * eps3der &
23737             + sigder * sigsq_om1     &
23738             + dCAVdOM1               &
23739             + dGCLdOM1               &
23740             + dPOLdOM1
23741
23742        eom2  =  &
23743               eps2der * eps2rt_om2   &
23744             + 2.0D0 * alf2 * eps3der &
23745             + sigder * sigsq_om2     &
23746             + dCAVdOM2               &
23747             + dGCLdOM2               &
23748             + dPOLdOM2
23749
23750        eom12 =    &
23751               evdwij  * eps1_om12     &
23752             + eps2der * eps2rt_om12   &
23753             - 2.0D0 * alf12 * eps3der &
23754             + sigder *sigsq_om12      &
23755             + dCAVdOM12               &
23756             + dGCLdOM12
23757
23758 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23759 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23760 !               gg(1),gg(2),"rozne"
23761        DO k = 1, 3
23762         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23763         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23764         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23765         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23766                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23767                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23768         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23769                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23770                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23771         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23772         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23773        END DO
23774        RETURN
23775       END SUBROUTINE sc_grad_scbase
23776
23777
23778       subroutine epep_sc_base(epepbase)
23779       use calc_data
23780       logical :: lprn
23781 !el local variables
23782       integer :: iint,itypi,itypi1,itypj,subchap
23783       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23784       real(kind=8) :: evdw,sig0ij
23785       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23786                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23787                     sslipi,sslipj,faclip
23788       integer :: ii
23789       real(kind=8) :: fracinbuf
23790        real (kind=8) :: epepbase
23791        real (kind=8),dimension(4):: ener
23792        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23793        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23794         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23795         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23796         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23797         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23798         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23799         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23800        real(kind=8),dimension(3,2)::chead,erhead_tail
23801        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23802        integer troll
23803        eps_out=80.0d0
23804        epepbase=0.0d0
23805 !       do i=1,nres_molec(1)-1
23806         do i=ibond_start,ibond_end
23807         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23808 !C        itypi  = itype(i,1)
23809         dxi    = dc_norm(1,i)
23810         dyi    = dc_norm(2,i)
23811         dzi    = dc_norm(3,i)
23812 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23813         dsci_inv = vbld_inv(i+1)/2.0
23814         xi=(c(1,i)+c(1,i+1))/2.0
23815         yi=(c(2,i)+c(2,i+1))/2.0
23816         zi=(c(3,i)+c(3,i+1))/2.0
23817         xi=mod(xi,boxxsize)
23818          if (xi.lt.0) xi=xi+boxxsize
23819         yi=mod(yi,boxysize)
23820          if (yi.lt.0) yi=yi+boxysize
23821         zi=mod(zi,boxzsize)
23822          if (zi.lt.0) zi=zi+boxzsize
23823          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23824            itypj= itype(j,2)
23825            if (itype(j,2).eq.ntyp1_molec(2))cycle
23826            xj=c(1,j+nres)
23827            yj=c(2,j+nres)
23828            zj=c(3,j+nres)
23829            xj=dmod(xj,boxxsize)
23830            if (xj.lt.0) xj=xj+boxxsize
23831            yj=dmod(yj,boxysize)
23832            if (yj.lt.0) yj=yj+boxysize
23833            zj=dmod(zj,boxzsize)
23834            if (zj.lt.0) zj=zj+boxzsize
23835           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23836           xj_safe=xj
23837           yj_safe=yj
23838           zj_safe=zj
23839           subchap=0
23840
23841           do xshift=-1,1
23842           do yshift=-1,1
23843           do zshift=-1,1
23844           xj=xj_safe+xshift*boxxsize
23845           yj=yj_safe+yshift*boxysize
23846           zj=zj_safe+zshift*boxzsize
23847           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23848           if(dist_temp.lt.dist_init) then
23849             dist_init=dist_temp
23850             xj_temp=xj
23851             yj_temp=yj
23852             zj_temp=zj
23853             subchap=1
23854           endif
23855           enddo
23856           enddo
23857           enddo
23858           if (subchap.eq.1) then
23859           xj=xj_temp-xi
23860           yj=yj_temp-yi
23861           zj=zj_temp-zi
23862           else
23863           xj=xj_safe-xi
23864           yj=yj_safe-yi
23865           zj=zj_safe-zi
23866           endif
23867           dxj = dc_norm( 1, nres+j )
23868           dyj = dc_norm( 2, nres+j )
23869           dzj = dc_norm( 3, nres+j )
23870 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23871 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23872
23873 ! Gay-berne var's
23874           sig0ij = sigma_pepbase(itypj )
23875           chi1   = chi_pepbase(itypj,1 )
23876           chi2   = chi_pepbase(itypj,2 )
23877 !          chi1=0.0d0
23878 !          chi2=0.0d0
23879           chi12  = chi1 * chi2
23880           chip1  = chipp_pepbase(itypj,1 )
23881           chip2  = chipp_pepbase(itypj,2 )
23882 !          chip1=0.0d0
23883 !          chip2=0.0d0
23884           chip12 = chip1 * chip2
23885           chis1 = chis_pepbase(itypj,1)
23886           chis2 = chis_pepbase(itypj,2)
23887           chis12 = chis1 * chis2
23888           sig1 = sigmap1_pepbase(itypj)
23889           sig2 = sigmap2_pepbase(itypj)
23890 !       write (*,*) "sig1 = ", sig1
23891 !       write (*,*) "sig2 = ", sig2
23892        DO k = 1,3
23893 ! location of polar head is computed by taking hydrophobic centre
23894 ! and moving by a d1 * dc_norm vector
23895 ! see unres publications for very informative images
23896         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23897 ! + d1i * dc_norm(k, i+nres)
23898         chead(k,2) = c(k, j+nres)
23899 ! + d1j * dc_norm(k, j+nres)
23900 ! distance
23901 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23902 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23903         Rhead_distance(k) = chead(k,2) - chead(k,1)
23904 !        print *,gvdwc_pepbase(k,i)
23905
23906        END DO
23907        Rhead = dsqrt( &
23908           (Rhead_distance(1)*Rhead_distance(1)) &
23909         + (Rhead_distance(2)*Rhead_distance(2)) &
23910         + (Rhead_distance(3)*Rhead_distance(3)))
23911
23912 ! alpha factors from Fcav/Gcav
23913           b1 = alphasur_pepbase(1,itypj)
23914 !          b1=0.0d0
23915           b2 = alphasur_pepbase(2,itypj)
23916           b3 = alphasur_pepbase(3,itypj)
23917           b4 = alphasur_pepbase(4,itypj)
23918           alf1   = 0.0d0
23919           alf2   = 0.0d0
23920           alf12  = 0.0d0
23921           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23922 !          print *,i,j,rrij
23923           rij  = dsqrt(rrij)
23924 !----------------------------
23925        evdwij = 0.0d0
23926        ECL = 0.0d0
23927        Elj = 0.0d0
23928        Equad = 0.0d0
23929        Epol = 0.0d0
23930        Fcav=0.0d0
23931        eheadtail = 0.0d0
23932        dGCLdOM1 = 0.0d0
23933        dGCLdOM2 = 0.0d0
23934        dGCLdOM12 = 0.0d0
23935        dPOLdOM1 = 0.0d0
23936        dPOLdOM2 = 0.0d0
23937           Fcav = 0.0d0
23938           dFdR = 0.0d0
23939           dCAVdOM1  = 0.0d0
23940           dCAVdOM2  = 0.0d0
23941           dCAVdOM12 = 0.0d0
23942           dscj_inv = vbld_inv(j+nres)
23943           CALL sc_angular
23944 ! this should be in elgrad_init but om's are calculated by sc_angular
23945 ! which in turn is used by older potentials
23946 ! om = omega, sqom = om^2
23947           sqom1  = om1 * om1
23948           sqom2  = om2 * om2
23949           sqom12 = om12 * om12
23950
23951 ! now we calculate EGB - Gey-Berne
23952 ! It will be summed up in evdwij and saved in evdw
23953           sigsq     = 1.0D0  / sigsq
23954           sig       = sig0ij * dsqrt(sigsq)
23955           rij_shift = 1.0/rij - sig + sig0ij
23956           IF (rij_shift.le.0.0D0) THEN
23957            evdw = 1.0D20
23958            RETURN
23959           END IF
23960           sigder = -sig * sigsq
23961           rij_shift = 1.0D0 / rij_shift
23962           fac       = rij_shift**expon
23963           c1        = fac  * fac * aa_pepbase(itypj)
23964 !          c1        = 0.0d0
23965           c2        = fac  * bb_pepbase(itypj)
23966 !          c2        = 0.0d0
23967           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23968           eps2der   = eps3rt * evdwij
23969           eps3der   = eps2rt * evdwij
23970 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23971           evdwij    = eps2rt * eps3rt * evdwij
23972           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23973           fac    = -expon * (c1 + evdwij) * rij_shift
23974           sigder = fac * sigder
23975 !          fac    = rij * fac
23976 ! Calculate distance derivative
23977           gg(1) =  fac
23978           gg(2) =  fac
23979           gg(3) =  fac
23980           fac = chis1 * sqom1 + chis2 * sqom2 &
23981           - 2.0d0 * chis12 * om1 * om2 * om12
23982 ! we will use pom later in Gcav, so dont mess with it!
23983           pom = 1.0d0 - chis1 * chis2 * sqom12
23984           Lambf = (1.0d0 - (fac / pom))
23985           Lambf = dsqrt(Lambf)
23986           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23987 !       write (*,*) "sparrow = ", sparrow
23988           Chif = 1.0d0/rij * sparrow
23989           ChiLambf = Chif * Lambf
23990           eagle = dsqrt(ChiLambf)
23991           bat = ChiLambf ** 11.0d0
23992           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23993           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23994           botsq = bot * bot
23995           Fcav = top / bot
23996 !          print *,i,j,Fcav
23997           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23998           dbot = 12.0d0 * b4 * bat * Lambf
23999           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24000 !       dFdR = 0.0d0
24001 !      write (*,*) "dFcav/dR = ", dFdR
24002           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24003           dbot = 12.0d0 * b4 * bat * Chif
24004           eagle = Lambf * pom
24005           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24006           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24007           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24008               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24009
24010           dFdL = ((dtop * bot - top * dbot) / botsq)
24011 !       dFdL = 0.0d0
24012           dCAVdOM1  = dFdL * ( dFdOM1 )
24013           dCAVdOM2  = dFdL * ( dFdOM2 )
24014           dCAVdOM12 = dFdL * ( dFdOM12 )
24015
24016           ertail(1) = xj*rij
24017           ertail(2) = yj*rij
24018           ertail(3) = zj*rij
24019        DO k = 1, 3
24020 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24021 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24022         pom = ertail(k)
24023 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24024         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24025                   - (( dFdR + gg(k) ) * pom)/2.0
24026 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24027 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24028 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24029 !     &             - ( dFdR * pom )
24030         pom = ertail(k)
24031 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24032         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24033                   + (( dFdR + gg(k) ) * pom)
24034 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24035 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24036 !c!     &             + ( dFdR * pom )
24037
24038         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24039                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24040 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24041
24042 !c!     &             - ( dFdR * ertail(k))
24043
24044         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24045                   + (( dFdR + gg(k) ) * ertail(k))
24046 !c!     &             + ( dFdR * ertail(k))
24047
24048         gg(k) = 0.0d0
24049 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24050 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24051       END DO
24052
24053
24054        w1 = wdipdip_pepbase(1,itypj)
24055        w2 = -wdipdip_pepbase(3,itypj)/2.0
24056        w3 = wdipdip_pepbase(2,itypj)
24057 !       w1=0.0d0
24058 !       w2=0.0d0
24059 !c!-------------------------------------------------------------------
24060 !c! ECL
24061 !       w3=0.0d0
24062        fac = (om12 - 3.0d0 * om1 * om2)
24063        c1 = (w1 / (Rhead**3.0d0)) * fac
24064        c2 = (w2 / Rhead ** 6.0d0)  &
24065          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24066        c3= (w3/ Rhead ** 6.0d0)  &
24067          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24068
24069        ECL = c1 - c2 + c3
24070
24071        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24072        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24073          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24074        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24075          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24076
24077        dGCLdR = c1 - c2 + c3
24078 !c! dECL/dom1
24079        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24080        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24081          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24082        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24083        dGCLdOM1 = c1 - c2 + c3
24084 !c! dECL/dom2
24085        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24086        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24087          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24088        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24089
24090        dGCLdOM2 = c1 - c2 + c3
24091 !c! dECL/dom12
24092        c1 = w1 / (Rhead ** 3.0d0)
24093        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24094        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24095        dGCLdOM12 = c1 - c2 + c3
24096        DO k= 1, 3
24097         erhead(k) = Rhead_distance(k)/Rhead
24098        END DO
24099        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24100        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24101 !       facd1 = d1 * vbld_inv(i+nres)
24102 !       facd2 = d2 * vbld_inv(j+nres)
24103        DO k = 1, 3
24104
24105 !        pom = erhead(k)
24106 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24107 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24108 !                  - dGCLdR * pom
24109         pom = erhead(k)
24110 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24111         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24112                   + dGCLdR * pom
24113
24114         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24115                   - dGCLdR * erhead(k)/2.0d0
24116 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24117         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24118                   - dGCLdR * erhead(k)/2.0d0
24119 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24120         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24121                   + dGCLdR * erhead(k)
24122        END DO
24123 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24124        epepbase=epepbase+evdwij+Fcav+ECL
24125        call sc_grad_pepbase
24126        enddo
24127        enddo
24128       END SUBROUTINE epep_sc_base
24129       SUBROUTINE sc_grad_pepbase
24130       use calc_data
24131
24132        real (kind=8) :: dcosom1(3),dcosom2(3)
24133        eom1  =    &
24134               eps2der * eps2rt_om1   &
24135             - 2.0D0 * alf1 * eps3der &
24136             + sigder * sigsq_om1     &
24137             + dCAVdOM1               &
24138             + dGCLdOM1               &
24139             + dPOLdOM1
24140
24141        eom2  =  &
24142               eps2der * eps2rt_om2   &
24143             + 2.0D0 * alf2 * eps3der &
24144             + sigder * sigsq_om2     &
24145             + dCAVdOM2               &
24146             + dGCLdOM2               &
24147             + dPOLdOM2
24148
24149        eom12 =    &
24150               evdwij  * eps1_om12     &
24151             + eps2der * eps2rt_om12   &
24152             - 2.0D0 * alf12 * eps3der &
24153             + sigder *sigsq_om12      &
24154             + dCAVdOM12               &
24155             + dGCLdOM12
24156 !        om12=0.0
24157 !        eom12=0.0
24158 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24159 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24160 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24161 !                 *dsci_inv*2.0
24162 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24163 !               gg(1),gg(2),"rozne"
24164        DO k = 1, 3
24165         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24166         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24167         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24168         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24169                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24170                  *dsci_inv*2.0 &
24171                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24172         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24173                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24174                  *dsci_inv*2.0 &
24175                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24176 !         print *,eom12,eom2,om12,om2
24177 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24178 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24179         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24180                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24181                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24182         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24183        END DO
24184        RETURN
24185       END SUBROUTINE sc_grad_pepbase
24186       subroutine eprot_sc_phosphate(escpho)
24187       use calc_data
24188 !      implicit real*8 (a-h,o-z)
24189 !      include 'DIMENSIONS'
24190 !      include 'COMMON.GEO'
24191 !      include 'COMMON.VAR'
24192 !      include 'COMMON.LOCAL'
24193 !      include 'COMMON.CHAIN'
24194 !      include 'COMMON.DERIV'
24195 !      include 'COMMON.NAMES'
24196 !      include 'COMMON.INTERACT'
24197 !      include 'COMMON.IOUNITS'
24198 !      include 'COMMON.CALC'
24199 !      include 'COMMON.CONTROL'
24200 !      include 'COMMON.SBRIDGE'
24201       logical :: lprn
24202 !el local variables
24203       integer :: iint,itypi,itypi1,itypj,subchap
24204       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24205       real(kind=8) :: evdw,sig0ij
24206       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24207                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24208                     sslipi,sslipj,faclip,alpha_sco
24209       integer :: ii
24210       real(kind=8) :: fracinbuf
24211        real (kind=8) :: escpho
24212        real (kind=8),dimension(4):: ener
24213        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24214        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24215         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24216         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24217         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24218         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24219         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24220         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24221        real(kind=8),dimension(3,2)::chead,erhead_tail
24222        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24223        integer troll
24224        eps_out=80.0d0
24225        escpho=0.0d0
24226 !       do i=1,nres_molec(1)
24227         do i=ibond_start,ibond_end
24228         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24229         itypi  = itype(i,1)
24230         dxi    = dc_norm(1,nres+i)
24231         dyi    = dc_norm(2,nres+i)
24232         dzi    = dc_norm(3,nres+i)
24233         dsci_inv = vbld_inv(i+nres)
24234         xi=c(1,nres+i)
24235         yi=c(2,nres+i)
24236         zi=c(3,nres+i)
24237         xi=mod(xi,boxxsize)
24238          if (xi.lt.0) xi=xi+boxxsize
24239         yi=mod(yi,boxysize)
24240          if (yi.lt.0) yi=yi+boxysize
24241         zi=mod(zi,boxzsize)
24242          if (zi.lt.0) zi=zi+boxzsize
24243          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24244            itypj= itype(j,2)
24245            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24246             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24247            xj=(c(1,j)+c(1,j+1))/2.0
24248            yj=(c(2,j)+c(2,j+1))/2.0
24249            zj=(c(3,j)+c(3,j+1))/2.0
24250            xj=dmod(xj,boxxsize)
24251            if (xj.lt.0) xj=xj+boxxsize
24252            yj=dmod(yj,boxysize)
24253            if (yj.lt.0) yj=yj+boxysize
24254            zj=dmod(zj,boxzsize)
24255            if (zj.lt.0) zj=zj+boxzsize
24256           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24257           xj_safe=xj
24258           yj_safe=yj
24259           zj_safe=zj
24260           subchap=0
24261           do xshift=-1,1
24262           do yshift=-1,1
24263           do zshift=-1,1
24264           xj=xj_safe+xshift*boxxsize
24265           yj=yj_safe+yshift*boxysize
24266           zj=zj_safe+zshift*boxzsize
24267           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24268           if(dist_temp.lt.dist_init) then
24269             dist_init=dist_temp
24270             xj_temp=xj
24271             yj_temp=yj
24272             zj_temp=zj
24273             subchap=1
24274           endif
24275           enddo
24276           enddo
24277           enddo
24278           if (subchap.eq.1) then
24279           xj=xj_temp-xi
24280           yj=yj_temp-yi
24281           zj=zj_temp-zi
24282           else
24283           xj=xj_safe-xi
24284           yj=yj_safe-yi
24285           zj=zj_safe-zi
24286           endif
24287           dxj = dc_norm( 1,j )
24288           dyj = dc_norm( 2,j )
24289           dzj = dc_norm( 3,j )
24290           dscj_inv = vbld_inv(j+1)
24291
24292 ! Gay-berne var's
24293           sig0ij = sigma_scpho(itypi )
24294           chi1   = chi_scpho(itypi,1 )
24295           chi2   = chi_scpho(itypi,2 )
24296 !          chi1=0.0d0
24297 !          chi2=0.0d0
24298           chi12  = chi1 * chi2
24299           chip1  = chipp_scpho(itypi,1 )
24300           chip2  = chipp_scpho(itypi,2 )
24301 !          chip1=0.0d0
24302 !          chip2=0.0d0
24303           chip12 = chip1 * chip2
24304           chis1 = chis_scpho(itypi,1)
24305           chis2 = chis_scpho(itypi,2)
24306           chis12 = chis1 * chis2
24307           sig1 = sigmap1_scpho(itypi)
24308           sig2 = sigmap2_scpho(itypi)
24309 !       write (*,*) "sig1 = ", sig1
24310 !       write (*,*) "sig1 = ", sig1
24311 !       write (*,*) "sig2 = ", sig2
24312 ! alpha factors from Fcav/Gcav
24313           alf1   = 0.0d0
24314           alf2   = 0.0d0
24315           alf12  = 0.0d0
24316           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24317
24318           b1 = alphasur_scpho(1,itypi)
24319 !          b1=0.0d0
24320           b2 = alphasur_scpho(2,itypi)
24321           b3 = alphasur_scpho(3,itypi)
24322           b4 = alphasur_scpho(4,itypi)
24323 ! used to determine whether we want to do quadrupole calculations
24324 ! used by Fgb
24325        eps_in = epsintab_scpho(itypi)
24326        if (eps_in.eq.0.0) eps_in=1.0
24327        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24328 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24329 !-------------------------------------------------------------------
24330 ! tail location and distance calculations
24331           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24332           d1j = 0.0
24333        DO k = 1,3
24334 ! location of polar head is computed by taking hydrophobic centre
24335 ! and moving by a d1 * dc_norm vector
24336 ! see unres publications for very informative images
24337         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24338         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24339 ! distance
24340 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24341 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24342         Rhead_distance(k) = chead(k,2) - chead(k,1)
24343        END DO
24344 ! pitagoras (root of sum of squares)
24345        Rhead = dsqrt( &
24346           (Rhead_distance(1)*Rhead_distance(1)) &
24347         + (Rhead_distance(2)*Rhead_distance(2)) &
24348         + (Rhead_distance(3)*Rhead_distance(3)))
24349        Rhead_sq=Rhead**2.0
24350 !-------------------------------------------------------------------
24351 ! zero everything that should be zero'ed
24352        evdwij = 0.0d0
24353        ECL = 0.0d0
24354        Elj = 0.0d0
24355        Equad = 0.0d0
24356        Epol = 0.0d0
24357        Fcav=0.0d0
24358        eheadtail = 0.0d0
24359        dGCLdR=0.0d0
24360        dGCLdOM1 = 0.0d0
24361        dGCLdOM2 = 0.0d0
24362        dGCLdOM12 = 0.0d0
24363        dPOLdOM1 = 0.0d0
24364        dPOLdOM2 = 0.0d0
24365           Fcav = 0.0d0
24366           dFdR = 0.0d0
24367           dCAVdOM1  = 0.0d0
24368           dCAVdOM2  = 0.0d0
24369           dCAVdOM12 = 0.0d0
24370           dscj_inv = vbld_inv(j+1)/2.0
24371 !dhead_scbasej(itypi,itypj)
24372 !          print *,i,j,dscj_inv,dsci_inv
24373 ! rij holds 1/(distance of Calpha atoms)
24374           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24375           rij  = dsqrt(rrij)
24376 !----------------------------
24377           CALL sc_angular
24378 ! this should be in elgrad_init but om's are calculated by sc_angular
24379 ! which in turn is used by older potentials
24380 ! om = omega, sqom = om^2
24381           sqom1  = om1 * om1
24382           sqom2  = om2 * om2
24383           sqom12 = om12 * om12
24384
24385 ! now we calculate EGB - Gey-Berne
24386 ! It will be summed up in evdwij and saved in evdw
24387           sigsq     = 1.0D0  / sigsq
24388           sig       = sig0ij * dsqrt(sigsq)
24389 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24390           rij_shift = 1.0/rij - sig + sig0ij
24391           IF (rij_shift.le.0.0D0) THEN
24392            evdw = 1.0D20
24393            RETURN
24394           END IF
24395           sigder = -sig * sigsq
24396           rij_shift = 1.0D0 / rij_shift
24397           fac       = rij_shift**expon
24398           c1        = fac  * fac * aa_scpho(itypi)
24399 !          c1        = 0.0d0
24400           c2        = fac  * bb_scpho(itypi)
24401 !          c2        = 0.0d0
24402           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24403           eps2der   = eps3rt * evdwij
24404           eps3der   = eps2rt * evdwij
24405 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24406           evdwij    = eps2rt * eps3rt * evdwij
24407           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24408           fac    = -expon * (c1 + evdwij) * rij_shift
24409           sigder = fac * sigder
24410 !          fac    = rij * fac
24411 ! Calculate distance derivative
24412           gg(1) =  fac
24413           gg(2) =  fac
24414           gg(3) =  fac
24415           fac = chis1 * sqom1 + chis2 * sqom2 &
24416           - 2.0d0 * chis12 * om1 * om2 * om12
24417 ! we will use pom later in Gcav, so dont mess with it!
24418           pom = 1.0d0 - chis1 * chis2 * sqom12
24419           Lambf = (1.0d0 - (fac / pom))
24420           Lambf = dsqrt(Lambf)
24421           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24422 !       write (*,*) "sparrow = ", sparrow
24423           Chif = 1.0d0/rij * sparrow
24424           ChiLambf = Chif * Lambf
24425           eagle = dsqrt(ChiLambf)
24426           bat = ChiLambf ** 11.0d0
24427           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24428           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24429           botsq = bot * bot
24430           Fcav = top / bot
24431           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24432           dbot = 12.0d0 * b4 * bat * Lambf
24433           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24434 !       dFdR = 0.0d0
24435 !      write (*,*) "dFcav/dR = ", dFdR
24436           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24437           dbot = 12.0d0 * b4 * bat * Chif
24438           eagle = Lambf * pom
24439           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24440           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24441           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24442               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24443
24444           dFdL = ((dtop * bot - top * dbot) / botsq)
24445 !       dFdL = 0.0d0
24446           dCAVdOM1  = dFdL * ( dFdOM1 )
24447           dCAVdOM2  = dFdL * ( dFdOM2 )
24448           dCAVdOM12 = dFdL * ( dFdOM12 )
24449
24450           ertail(1) = xj*rij
24451           ertail(2) = yj*rij
24452           ertail(3) = zj*rij
24453        DO k = 1, 3
24454 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24455 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24456 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24457
24458         pom = ertail(k)
24459 !        print *,pom,gg(k),dFdR
24460 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24461         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24462                   - (( dFdR + gg(k) ) * pom)
24463 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24464 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24465 !     &             - ( dFdR * pom )
24466 !        pom = ertail(k)
24467 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24468 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24469 !                  + (( dFdR + gg(k) ) * pom)
24470 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24471 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24472 !c!     &             + ( dFdR * pom )
24473
24474         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24475                   - (( dFdR + gg(k) ) * ertail(k))
24476 !c!     &             - ( dFdR * ertail(k))
24477
24478         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24479                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24480
24481         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24482                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24483
24484 !c!     &             + ( dFdR * ertail(k))
24485
24486         gg(k) = 0.0d0
24487         ENDDO
24488 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24489 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24490 !      alphapol1 = alphapol_scpho(itypi)
24491        if (wqq_scpho(itypi).ne.0.0) then
24492        Qij=wqq_scpho(itypi)/eps_in
24493        alpha_sco=1.d0/alphi_scpho(itypi)
24494 !       Qij=0.0
24495        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24496 !c! derivative of Ecl is Gcl...
24497        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24498                 (Rhead*alpha_sco+1) ) / Rhead_sq
24499        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24500        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24501        w1        = wqdip_scpho(1,itypi)
24502        w2        = wqdip_scpho(2,itypi)
24503 !       w1=0.0d0
24504 !       w2=0.0d0
24505 !       pis       = sig0head_scbase(itypi,itypj)
24506 !       eps_head   = epshead_scbase(itypi,itypj)
24507 !c!-------------------------------------------------------------------
24508
24509 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24510 !c!     &        +dhead(1,1,itypi,itypj))**2))
24511 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24512 !c!     &        +dhead(2,1,itypi,itypj))**2))
24513
24514 !c!-------------------------------------------------------------------
24515 !c! ecl
24516        sparrow  = w1  *  om1
24517        hawk     = w2 *  (1.0d0 - sqom2)
24518        Ecl = sparrow / Rhead**2.0d0 &
24519            - hawk    / Rhead**4.0d0
24520 !c!-------------------------------------------------------------------
24521        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24522            1.0/rij,sparrow
24523
24524 !c! derivative of ecl is Gcl
24525 !c! dF/dr part
24526        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24527                 + 4.0d0 * hawk    / Rhead**5.0d0
24528 !c! dF/dom1
24529        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24530 !c! dF/dom2
24531        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24532        endif
24533
24534 !c--------------------------------------------------------------------
24535 !c Polarization energy
24536 !c Epol
24537        R1 = 0.0d0
24538        DO k = 1, 3
24539 !c! Calculate head-to-tail distances tail is center of side-chain
24540         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24541        END DO
24542 !c! Pitagoras
24543        R1 = dsqrt(R1)
24544
24545       alphapol1 = alphapol_scpho(itypi)
24546 !      alphapol1=0.0
24547        MomoFac1 = (1.0d0 - chi2 * sqom1)
24548        RR1  = R1 * R1 / MomoFac1
24549        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24550 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24551        fgb1 = sqrt( RR1 + a12sq * ee1)
24552 !       eps_inout_fac=0.0d0
24553        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24554 ! derivative of Epol is Gpol...
24555        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24556                 / (fgb1 ** 5.0d0)
24557        dFGBdR1 = ( (R1 / MomoFac1) &
24558              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24559              / ( 2.0d0 * fgb1 )
24560        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24561                * (2.0d0 - 0.5d0 * ee1) ) &
24562                / (2.0d0 * fgb1)
24563        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24564 !       dPOLdR1 = 0.0d0
24565 !       dPOLdOM1 = 0.0d0
24566        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24567                * (2.0d0 - 0.5d0 * ee1) ) &
24568                / (2.0d0 * fgb1)
24569
24570        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24571        dPOLdOM2 = 0.0
24572        DO k = 1, 3
24573         erhead(k) = Rhead_distance(k)/Rhead
24574         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24575        END DO
24576
24577        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24578        erdxj = scalar( erhead(1), dC_norm(1,j) )
24579        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24580 !       bat=0.0d0
24581        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24582        facd1 = d1i * vbld_inv(i+nres)
24583        facd2 = d1j * vbld_inv(j)
24584 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24585
24586        DO k = 1, 3
24587         hawk = (erhead_tail(k,1) + &
24588         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24589 !        facd1=0.0d0
24590 !        facd2=0.0d0
24591 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24592 !                pom,(erhead_tail(k,1))
24593
24594 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24595         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24596         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24597                    - dGCLdR * pom &
24598                    - dPOLdR1 *  (erhead_tail(k,1))
24599 !     &             - dGLJdR * pom
24600
24601         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24602 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24603 !                   + dGCLdR * pom  &
24604 !                   + dPOLdR1 * (erhead_tail(k,1))
24605 !     &             + dGLJdR * pom
24606
24607
24608         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24609                   - dGCLdR * erhead(k) &
24610                   - dPOLdR1 * erhead_tail(k,1)
24611 !     &             - dGLJdR * erhead(k)
24612
24613         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24614                   + (dGCLdR * erhead(k)  &
24615                   + dPOLdR1 * erhead_tail(k,1))/2.0
24616         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24617                   + (dGCLdR * erhead(k)  &
24618                   + dPOLdR1 * erhead_tail(k,1))/2.0
24619
24620 !     &             + dGLJdR * erhead(k)
24621 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24622
24623        END DO
24624 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24625        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24626         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24627        escpho=escpho+evdwij+epol+Fcav+ECL
24628        call sc_grad_scpho
24629          enddo
24630
24631       enddo
24632
24633       return
24634       end subroutine eprot_sc_phosphate
24635       SUBROUTINE sc_grad_scpho
24636       use calc_data
24637
24638        real (kind=8) :: dcosom1(3),dcosom2(3)
24639        eom1  =    &
24640               eps2der * eps2rt_om1   &
24641             - 2.0D0 * alf1 * eps3der &
24642             + sigder * sigsq_om1     &
24643             + dCAVdOM1               &
24644             + dGCLdOM1               &
24645             + dPOLdOM1
24646
24647        eom2  =  &
24648               eps2der * eps2rt_om2   &
24649             + 2.0D0 * alf2 * eps3der &
24650             + sigder * sigsq_om2     &
24651             + dCAVdOM2               &
24652             + dGCLdOM2               &
24653             + dPOLdOM2
24654
24655        eom12 =    &
24656               evdwij  * eps1_om12     &
24657             + eps2der * eps2rt_om12   &
24658             - 2.0D0 * alf12 * eps3der &
24659             + sigder *sigsq_om12      &
24660             + dCAVdOM12               &
24661             + dGCLdOM12
24662 !        om12=0.0
24663 !        eom12=0.0
24664 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24665 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24666 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24667 !                 *dsci_inv*2.0
24668 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24669 !               gg(1),gg(2),"rozne"
24670        DO k = 1, 3
24671         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24672         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24673         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24674         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24675                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24676                  *dscj_inv*2.0 &
24677                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24678         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24679                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24680                  *dscj_inv*2.0 &
24681                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24682         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24683                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24684                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24685
24686 !         print *,eom12,eom2,om12,om2
24687 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24688 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24689 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24690 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24691 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24692         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24693        END DO
24694        RETURN
24695       END SUBROUTINE sc_grad_scpho
24696       subroutine eprot_pep_phosphate(epeppho)
24697       use calc_data
24698 !      implicit real*8 (a-h,o-z)
24699 !      include 'DIMENSIONS'
24700 !      include 'COMMON.GEO'
24701 !      include 'COMMON.VAR'
24702 !      include 'COMMON.LOCAL'
24703 !      include 'COMMON.CHAIN'
24704 !      include 'COMMON.DERIV'
24705 !      include 'COMMON.NAMES'
24706 !      include 'COMMON.INTERACT'
24707 !      include 'COMMON.IOUNITS'
24708 !      include 'COMMON.CALC'
24709 !      include 'COMMON.CONTROL'
24710 !      include 'COMMON.SBRIDGE'
24711       logical :: lprn
24712 !el local variables
24713       integer :: iint,itypi,itypi1,itypj,subchap
24714       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24715       real(kind=8) :: evdw,sig0ij
24716       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24717                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24718                     sslipi,sslipj,faclip
24719       integer :: ii
24720       real(kind=8) :: fracinbuf
24721        real (kind=8) :: epeppho
24722        real (kind=8),dimension(4):: ener
24723        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24724        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24725         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24726         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24727         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24728         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24729         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24730         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24731        real(kind=8),dimension(3,2)::chead,erhead_tail
24732        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24733        integer troll
24734        real (kind=8) :: dcosom1(3),dcosom2(3)
24735        epeppho=0.0d0
24736 !       do i=1,nres_molec(1)
24737         do i=ibond_start,ibond_end
24738         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24739         itypi  = itype(i,1)
24740         dsci_inv = vbld_inv(i+1)/2.0
24741         dxi    = dc_norm(1,i)
24742         dyi    = dc_norm(2,i)
24743         dzi    = dc_norm(3,i)
24744         xi=(c(1,i)+c(1,i+1))/2.0
24745         yi=(c(2,i)+c(2,i+1))/2.0
24746         zi=(c(3,i)+c(3,i+1))/2.0
24747         xi=mod(xi,boxxsize)
24748          if (xi.lt.0) xi=xi+boxxsize
24749         yi=mod(yi,boxysize)
24750          if (yi.lt.0) yi=yi+boxysize
24751         zi=mod(zi,boxzsize)
24752          if (zi.lt.0) zi=zi+boxzsize
24753          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24754            itypj= itype(j,2)
24755            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24756             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24757            xj=(c(1,j)+c(1,j+1))/2.0
24758            yj=(c(2,j)+c(2,j+1))/2.0
24759            zj=(c(3,j)+c(3,j+1))/2.0
24760            xj=dmod(xj,boxxsize)
24761            if (xj.lt.0) xj=xj+boxxsize
24762            yj=dmod(yj,boxysize)
24763            if (yj.lt.0) yj=yj+boxysize
24764            zj=dmod(zj,boxzsize)
24765            if (zj.lt.0) zj=zj+boxzsize
24766           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24767           xj_safe=xj
24768           yj_safe=yj
24769           zj_safe=zj
24770           subchap=0
24771           do xshift=-1,1
24772           do yshift=-1,1
24773           do zshift=-1,1
24774           xj=xj_safe+xshift*boxxsize
24775           yj=yj_safe+yshift*boxysize
24776           zj=zj_safe+zshift*boxzsize
24777           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24778           if(dist_temp.lt.dist_init) then
24779             dist_init=dist_temp
24780             xj_temp=xj
24781             yj_temp=yj
24782             zj_temp=zj
24783             subchap=1
24784           endif
24785           enddo
24786           enddo
24787           enddo
24788           if (subchap.eq.1) then
24789           xj=xj_temp-xi
24790           yj=yj_temp-yi
24791           zj=zj_temp-zi
24792           else
24793           xj=xj_safe-xi
24794           yj=yj_safe-yi
24795           zj=zj_safe-zi
24796           endif
24797           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24798           rij  = dsqrt(rrij)
24799           dxj = dc_norm( 1,j )
24800           dyj = dc_norm( 2,j )
24801           dzj = dc_norm( 3,j )
24802           dscj_inv = vbld_inv(j+1)/2.0
24803 ! Gay-berne var's
24804           sig0ij = sigma_peppho
24805 !          chi1=0.0d0
24806 !          chi2=0.0d0
24807           chi12  = chi1 * chi2
24808 !          chip1=0.0d0
24809 !          chip2=0.0d0
24810           chip12 = chip1 * chip2
24811 !          chis1 = 0.0d0
24812 !          chis2 = 0.0d0
24813           chis12 = chis1 * chis2
24814           sig1 = sigmap1_peppho
24815           sig2 = sigmap2_peppho
24816 !       write (*,*) "sig1 = ", sig1
24817 !       write (*,*) "sig1 = ", sig1
24818 !       write (*,*) "sig2 = ", sig2
24819 ! alpha factors from Fcav/Gcav
24820           alf1   = 0.0d0
24821           alf2   = 0.0d0
24822           alf12  = 0.0d0
24823           b1 = alphasur_peppho(1)
24824 !          b1=0.0d0
24825           b2 = alphasur_peppho(2)
24826           b3 = alphasur_peppho(3)
24827           b4 = alphasur_peppho(4)
24828           CALL sc_angular
24829        sqom1=om1*om1
24830        evdwij = 0.0d0
24831        ECL = 0.0d0
24832        Elj = 0.0d0
24833        Equad = 0.0d0
24834        Epol = 0.0d0
24835        Fcav=0.0d0
24836        eheadtail = 0.0d0
24837        dGCLdR=0.0d0
24838        dGCLdOM1 = 0.0d0
24839        dGCLdOM2 = 0.0d0
24840        dGCLdOM12 = 0.0d0
24841        dPOLdOM1 = 0.0d0
24842        dPOLdOM2 = 0.0d0
24843           Fcav = 0.0d0
24844           dFdR = 0.0d0
24845           dCAVdOM1  = 0.0d0
24846           dCAVdOM2  = 0.0d0
24847           dCAVdOM12 = 0.0d0
24848           rij_shift = rij
24849           fac       = rij_shift**expon
24850           c1        = fac  * fac * aa_peppho
24851 !          c1        = 0.0d0
24852           c2        = fac  * bb_peppho
24853 !          c2        = 0.0d0
24854           evdwij    =  c1 + c2
24855 ! Now cavity....................
24856        eagle = dsqrt(1.0/rij_shift)
24857        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24858           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24859           botsq = bot * bot
24860           Fcav = top / bot
24861           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24862           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24863           dFdR = ((dtop * bot - top * dbot) / botsq)
24864        w1        = wqdip_peppho(1)
24865        w2        = wqdip_peppho(2)
24866 !       w1=0.0d0
24867 !       w2=0.0d0
24868 !       pis       = sig0head_scbase(itypi,itypj)
24869 !       eps_head   = epshead_scbase(itypi,itypj)
24870 !c!-------------------------------------------------------------------
24871
24872 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24873 !c!     &        +dhead(1,1,itypi,itypj))**2))
24874 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24875 !c!     &        +dhead(2,1,itypi,itypj))**2))
24876
24877 !c!-------------------------------------------------------------------
24878 !c! ecl
24879        sparrow  = w1  *  om1
24880        hawk     = w2 *  (1.0d0 - sqom1)
24881        Ecl = sparrow * rij_shift**2.0d0 &
24882            - hawk    * rij_shift**4.0d0
24883 !c!-------------------------------------------------------------------
24884 !c! derivative of ecl is Gcl
24885 !c! dF/dr part
24886 !       rij_shift=5.0
24887        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24888                 + 4.0d0 * hawk    * rij_shift**5.0d0
24889 !c! dF/dom1
24890        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24891 !c! dF/dom2
24892        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24893        eom1  =    dGCLdOM1+dGCLdOM2
24894        eom2  =    0.0
24895
24896           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24897 !          fac=0.0
24898           gg(1) =  fac*xj*rij
24899           gg(2) =  fac*yj*rij
24900           gg(3) =  fac*zj*rij
24901          do k=1,3
24902          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24903          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24904          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24905          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24906          gg(k)=0.0
24907          enddo
24908
24909       DO k = 1, 3
24910         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24911         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24912         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24913         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24914 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24915         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24916 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24917         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24918                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24919         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24920                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24921         enddo
24922        epeppho=epeppho+evdwij+Fcav+ECL
24923 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24924        enddo
24925        enddo
24926       end subroutine eprot_pep_phosphate
24927 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24928       subroutine emomo(evdw)
24929       use calc_data
24930       use comm_momo
24931 !      implicit real*8 (a-h,o-z)
24932 !      include 'DIMENSIONS'
24933 !      include 'COMMON.GEO'
24934 !      include 'COMMON.VAR'
24935 !      include 'COMMON.LOCAL'
24936 !      include 'COMMON.CHAIN'
24937 !      include 'COMMON.DERIV'
24938 !      include 'COMMON.NAMES'
24939 !      include 'COMMON.INTERACT'
24940 !      include 'COMMON.IOUNITS'
24941 !      include 'COMMON.CALC'
24942 !      include 'COMMON.CONTROL'
24943 !      include 'COMMON.SBRIDGE'
24944       logical :: lprn
24945 !el local variables
24946       integer :: iint,itypi1,subchap,isel
24947       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24948       real(kind=8) :: evdw
24949       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24950                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24951                     sslipi,sslipj,faclip,alpha_sco
24952       integer :: ii
24953       real(kind=8) :: fracinbuf
24954        real (kind=8) :: escpho
24955        real (kind=8),dimension(4):: ener
24956        real(kind=8) :: b1,b2,egb
24957        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24958         Lambf,&
24959         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24960         dFdOM2,dFdL,dFdOM12,&
24961         federmaus,&
24962         d1i,d1j
24963 !       real(kind=8),dimension(3,2)::erhead_tail
24964 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
24965        real(kind=8) ::  facd4, adler, Fgb, facd3
24966        integer troll,jj,istate
24967        real (kind=8) :: dcosom1(3),dcosom2(3)
24968        eps_out=80.0d0
24969        sss_ele_cut=1.0d0
24970 !       print *,"EVDW KURW",evdw,nres
24971       do i=iatsc_s,iatsc_e
24972 !        print *,"I am in EVDW",i
24973         itypi=iabs(itype(i,1))
24974 !        if (i.ne.47) cycle
24975         if (itypi.eq.ntyp1) cycle
24976         itypi1=iabs(itype(i+1,1))
24977         xi=c(1,nres+i)
24978         yi=c(2,nres+i)
24979         zi=c(3,nres+i)
24980           xi=dmod(xi,boxxsize)
24981           if (xi.lt.0) xi=xi+boxxsize
24982           yi=dmod(yi,boxysize)
24983           if (yi.lt.0) yi=yi+boxysize
24984           zi=dmod(zi,boxzsize)
24985           if (zi.lt.0) zi=zi+boxzsize
24986
24987        if ((zi.gt.bordlipbot)  &
24988         .and.(zi.lt.bordliptop)) then
24989 !C the energy transfer exist
24990         if (zi.lt.buflipbot) then
24991 !C what fraction I am in
24992          fracinbuf=1.0d0-  &
24993               ((zi-bordlipbot)/lipbufthick)
24994 !C lipbufthick is thickenes of lipid buffore
24995          sslipi=sscalelip(fracinbuf)
24996          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
24997         elseif (zi.gt.bufliptop) then
24998          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
24999          sslipi=sscalelip(fracinbuf)
25000          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25001         else
25002          sslipi=1.0d0
25003          ssgradlipi=0.0
25004         endif
25005        else
25006          sslipi=0.0d0
25007          ssgradlipi=0.0
25008        endif
25009 !       print *, sslipi,ssgradlipi
25010         dxi=dc_norm(1,nres+i)
25011         dyi=dc_norm(2,nres+i)
25012         dzi=dc_norm(3,nres+i)
25013 !        dsci_inv=dsc_inv(itypi)
25014         dsci_inv=vbld_inv(i+nres)
25015 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25016 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25017 !
25018 ! Calculate SC interaction energy.
25019 !
25020         do iint=1,nint_gr(i)
25021           do j=istart(i,iint),iend(i,iint)
25022 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25023             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25024               call dyn_ssbond_ene(i,j,evdwij)
25025               evdw=evdw+evdwij
25026               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25027                               'evdw',i,j,evdwij,' ss'
25028 !              if (energy_dec) write (iout,*) &
25029 !                              'evdw',i,j,evdwij,' ss'
25030              do k=j+1,iend(i,iint)
25031 !C search over all next residues
25032               if (dyn_ss_mask(k)) then
25033 !C check if they are cysteins
25034 !C              write(iout,*) 'k=',k
25035
25036 !c              write(iout,*) "PRZED TRI", evdwij
25037 !               evdwij_przed_tri=evdwij
25038               call triple_ssbond_ene(i,j,k,evdwij)
25039 !c               if(evdwij_przed_tri.ne.evdwij) then
25040 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25041 !c               endif
25042
25043 !c              write(iout,*) "PO TRI", evdwij
25044 !C call the energy function that removes the artifical triple disulfide
25045 !C bond the soubroutine is located in ssMD.F
25046               evdw=evdw+evdwij
25047               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25048                             'evdw',i,j,evdwij,'tss'
25049               endif!dyn_ss_mask(k)
25050              enddo! k
25051             ELSE
25052 !el            ind=ind+1
25053             itypj=iabs(itype(j,1))
25054             if (itypj.eq.ntyp1) cycle
25055              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25056
25057 !             if (j.ne.78) cycle
25058 !            dscj_inv=dsc_inv(itypj)
25059             dscj_inv=vbld_inv(j+nres)
25060            xj=c(1,j+nres)
25061            yj=c(2,j+nres)
25062            zj=c(3,j+nres)
25063            xj=dmod(xj,boxxsize)
25064            if (xj.lt.0) xj=xj+boxxsize
25065            yj=dmod(yj,boxysize)
25066            if (yj.lt.0) yj=yj+boxysize
25067            zj=dmod(zj,boxzsize)
25068            if (zj.lt.0) zj=zj+boxzsize
25069           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25070           xj_safe=xj
25071           yj_safe=yj
25072           zj_safe=zj
25073           subchap=0
25074
25075           do xshift=-1,1
25076           do yshift=-1,1
25077           do zshift=-1,1
25078           xj=xj_safe+xshift*boxxsize
25079           yj=yj_safe+yshift*boxysize
25080           zj=zj_safe+zshift*boxzsize
25081           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25082           if(dist_temp.lt.dist_init) then
25083             dist_init=dist_temp
25084             xj_temp=xj
25085             yj_temp=yj
25086             zj_temp=zj
25087             subchap=1
25088           endif
25089           enddo
25090           enddo
25091           enddo
25092           if (subchap.eq.1) then
25093           xj=xj_temp-xi
25094           yj=yj_temp-yi
25095           zj=zj_temp-zi
25096           else
25097           xj=xj_safe-xi
25098           yj=yj_safe-yi
25099           zj=zj_safe-zi
25100           endif
25101           dxj = dc_norm( 1, nres+j )
25102           dyj = dc_norm( 2, nres+j )
25103           dzj = dc_norm( 3, nres+j )
25104 !          print *,i,j,itypi,itypj
25105 !          d1i=0.0d0
25106 !          d1j=0.0d0
25107 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25108 ! Gay-berne var's
25109 !1!          sig0ij = sigma_scsc( itypi,itypj )
25110 !          chi1=0.0d0
25111 !          chi2=0.0d0
25112 !          chip1=0.0d0
25113 !          chip2=0.0d0
25114 ! not used by momo potential, but needed by sc_angular which is shared
25115 ! by all energy_potential subroutines
25116           alf1   = 0.0d0
25117           alf2   = 0.0d0
25118           alf12  = 0.0d0
25119           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25120 !       a12sq = a12sq * a12sq
25121 ! charge of amino acid itypi is...
25122           chis1 = chis(itypi,itypj)
25123           chis2 = chis(itypj,itypi)
25124           chis12 = chis1 * chis2
25125           sig1 = sigmap1(itypi,itypj)
25126           sig2 = sigmap2(itypi,itypj)
25127 !       write (*,*) "sig1 = ", sig1
25128 !          chis1=0.0
25129 !          chis2=0.0
25130 !                    chis12 = chis1 * chis2
25131 !          sig1=0.0
25132 !          sig2=0.0
25133 !       write (*,*) "sig2 = ", sig2
25134 ! alpha factors from Fcav/Gcav
25135           b1cav = alphasur(1,itypi,itypj)
25136 !          b1cav=0.0d0
25137           b2cav = alphasur(2,itypi,itypj)
25138           b3cav = alphasur(3,itypi,itypj)
25139           b4cav = alphasur(4,itypi,itypj)
25140 ! used to determine whether we want to do quadrupole calculations
25141        eps_in = epsintab(itypi,itypj)
25142        if (eps_in.eq.0.0) eps_in=1.0
25143
25144        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25145        Rtail = 0.0d0
25146 !       dtail(1,itypi,itypj)=0.0
25147 !       dtail(2,itypi,itypj)=0.0
25148
25149        DO k = 1, 3
25150         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25151         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25152        END DO
25153 !c! tail distances will be themselves usefull elswhere
25154 !c1 (in Gcav, for example)
25155        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25156        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25157        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25158        Rtail = dsqrt( &
25159           (Rtail_distance(1)*Rtail_distance(1)) &
25160         + (Rtail_distance(2)*Rtail_distance(2)) &
25161         + (Rtail_distance(3)*Rtail_distance(3)))
25162
25163 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25164 !-------------------------------------------------------------------
25165 ! tail location and distance calculations
25166        d1 = dhead(1, 1, itypi, itypj)
25167        d2 = dhead(2, 1, itypi, itypj)
25168
25169        DO k = 1,3
25170 ! location of polar head is computed by taking hydrophobic centre
25171 ! and moving by a d1 * dc_norm vector
25172 ! see unres publications for very informative images
25173         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25174         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25175 ! distance
25176 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25177 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25178         Rhead_distance(k) = chead(k,2) - chead(k,1)
25179        END DO
25180 ! pitagoras (root of sum of squares)
25181        Rhead = dsqrt( &
25182           (Rhead_distance(1)*Rhead_distance(1)) &
25183         + (Rhead_distance(2)*Rhead_distance(2)) &
25184         + (Rhead_distance(3)*Rhead_distance(3)))
25185 !-------------------------------------------------------------------
25186 ! zero everything that should be zero'ed
25187        evdwij = 0.0d0
25188        ECL = 0.0d0
25189        Elj = 0.0d0
25190        Equad = 0.0d0
25191        Epol = 0.0d0
25192        Fcav=0.0d0
25193        eheadtail = 0.0d0
25194        dGCLdOM1 = 0.0d0
25195        dGCLdOM2 = 0.0d0
25196        dGCLdOM12 = 0.0d0
25197        dPOLdOM1 = 0.0d0
25198        dPOLdOM2 = 0.0d0
25199           Fcav = 0.0d0
25200           dFdR = 0.0d0
25201           dCAVdOM1  = 0.0d0
25202           dCAVdOM2  = 0.0d0
25203           dCAVdOM12 = 0.0d0
25204           dscj_inv = vbld_inv(j+nres)
25205 !          print *,i,j,dscj_inv,dsci_inv
25206 ! rij holds 1/(distance of Calpha atoms)
25207           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25208           rij  = dsqrt(rrij)
25209 !----------------------------
25210           CALL sc_angular
25211 ! this should be in elgrad_init but om's are calculated by sc_angular
25212 ! which in turn is used by older potentials
25213 ! om = omega, sqom = om^2
25214           sqom1  = om1 * om1
25215           sqom2  = om2 * om2
25216           sqom12 = om12 * om12
25217
25218 ! now we calculate EGB - Gey-Berne
25219 ! It will be summed up in evdwij and saved in evdw
25220           sigsq     = 1.0D0  / sigsq
25221           sig       = sig0ij * dsqrt(sigsq)
25222 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25223           rij_shift = Rtail - sig + sig0ij
25224           IF (rij_shift.le.0.0D0) THEN
25225            evdw = 1.0D20
25226            RETURN
25227           END IF
25228           sigder = -sig * sigsq
25229           rij_shift = 1.0D0 / rij_shift
25230           fac       = rij_shift**expon
25231           c1        = fac  * fac * aa_aq(itypi,itypj)
25232 !          print *,"ADAM",aa_aq(itypi,itypj)
25233
25234 !          c1        = 0.0d0
25235           c2        = fac  * bb_aq(itypi,itypj)
25236 !          c2        = 0.0d0
25237           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25238           eps2der   = eps3rt * evdwij
25239           eps3der   = eps2rt * evdwij
25240 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25241           evdwij    = eps2rt * eps3rt * evdwij
25242 !#ifdef TSCSC
25243 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25244 !           evdw_p = evdw_p + evdwij
25245 !          ELSE
25246 !           evdw_m = evdw_m + evdwij
25247 !          END IF
25248 !#else
25249           evdw = evdw  &
25250               + evdwij
25251 !#endif
25252
25253           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25254           fac    = -expon * (c1 + evdwij) * rij_shift
25255           sigder = fac * sigder
25256 !          fac    = rij * fac
25257 ! Calculate distance derivative
25258           gg(1) =  fac
25259           gg(2) =  fac
25260           gg(3) =  fac
25261 !          if (b2.gt.0.0) then
25262           fac = chis1 * sqom1 + chis2 * sqom2 &
25263           - 2.0d0 * chis12 * om1 * om2 * om12
25264 ! we will use pom later in Gcav, so dont mess with it!
25265           pom = 1.0d0 - chis1 * chis2 * sqom12
25266           Lambf = (1.0d0 - (fac / pom))
25267 !          print *,"fac,pom",fac,pom,Lambf
25268           Lambf = dsqrt(Lambf)
25269           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25270 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25271 !       write (*,*) "sparrow = ", sparrow
25272           Chif = Rtail * sparrow
25273 !           print *,"rij,sparrow",rij , sparrow
25274           ChiLambf = Chif * Lambf
25275           eagle = dsqrt(ChiLambf)
25276           bat = ChiLambf ** 11.0d0
25277           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25278           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25279           botsq = bot * bot
25280 !          print *,top,bot,"bot,top",ChiLambf,Chif
25281           Fcav = top / bot
25282
25283        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25284        dbot = 12.0d0 * b4cav * bat * Lambf
25285        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25286
25287           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25288           dbot = 12.0d0 * b4cav * bat * Chif
25289           eagle = Lambf * pom
25290           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25291           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25292           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25293               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25294
25295           dFdL = ((dtop * bot - top * dbot) / botsq)
25296 !       dFdL = 0.0d0
25297           dCAVdOM1  = dFdL * ( dFdOM1 )
25298           dCAVdOM2  = dFdL * ( dFdOM2 )
25299           dCAVdOM12 = dFdL * ( dFdOM12 )
25300
25301        DO k= 1, 3
25302         ertail(k) = Rtail_distance(k)/Rtail
25303        END DO
25304        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25305        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25306        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25307        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25308        DO k = 1, 3
25309 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25310 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25311         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25312         gvdwx(k,i) = gvdwx(k,i) &
25313                   - (( dFdR + gg(k) ) * pom)
25314 !c!     &             - ( dFdR * pom )
25315         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25316         gvdwx(k,j) = gvdwx(k,j)   &
25317                   + (( dFdR + gg(k) ) * pom)
25318 !c!     &             + ( dFdR * pom )
25319
25320         gvdwc(k,i) = gvdwc(k,i)  &
25321                   - (( dFdR + gg(k) ) * ertail(k))
25322 !c!     &             - ( dFdR * ertail(k))
25323
25324         gvdwc(k,j) = gvdwc(k,j) &
25325                   + (( dFdR + gg(k) ) * ertail(k))
25326 !c!     &             + ( dFdR * ertail(k))
25327
25328         gg(k) = 0.0d0
25329 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25330 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25331       END DO
25332
25333
25334 !c! Compute head-head and head-tail energies for each state
25335
25336           isel = iabs(Qi) + iabs(Qj)
25337 ! double charge for Phophorylated! itype - 25,27,27
25338 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25339 !            Qi=Qi*2
25340 !            Qij=Qij*2
25341 !           endif
25342 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25343 !            Qj=Qj*2
25344 !            Qij=Qij*2
25345 !           endif
25346
25347 !          isel=0
25348           IF (isel.eq.0) THEN
25349 !c! No charges - do nothing
25350            eheadtail = 0.0d0
25351
25352           ELSE IF (isel.eq.4) THEN
25353 !c! Calculate dipole-dipole interactions
25354            CALL edd(ecl)
25355            eheadtail = ECL
25356 !           eheadtail = 0.0d0
25357
25358           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25359 !c! Charge-nonpolar interactions
25360           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25361             Qi=Qi*2
25362             Qij=Qij*2
25363            endif
25364           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25365             Qj=Qj*2
25366             Qij=Qij*2
25367            endif
25368
25369            CALL eqn(epol)
25370            eheadtail = epol
25371 !           eheadtail = 0.0d0
25372
25373           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25374 !c! Nonpolar-charge interactions
25375           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25376             Qi=Qi*2
25377             Qij=Qij*2
25378            endif
25379           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25380             Qj=Qj*2
25381             Qij=Qij*2
25382            endif
25383
25384            CALL enq(epol)
25385            eheadtail = epol
25386 !           eheadtail = 0.0d0
25387
25388           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25389 !c! Charge-dipole interactions
25390           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25391             Qi=Qi*2
25392             Qij=Qij*2
25393            endif
25394           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25395             Qj=Qj*2
25396             Qij=Qij*2
25397            endif
25398
25399            CALL eqd(ecl, elj, epol)
25400            eheadtail = ECL + elj + epol
25401 !           eheadtail = 0.0d0
25402
25403           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25404 !c! Dipole-charge interactions
25405           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25406             Qi=Qi*2
25407             Qij=Qij*2
25408            endif
25409           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25410             Qj=Qj*2
25411             Qij=Qij*2
25412            endif
25413            CALL edq(ecl, elj, epol)
25414           eheadtail = ECL + elj + epol
25415 !           eheadtail = 0.0d0
25416
25417           ELSE IF ((isel.eq.2.and.   &
25418                iabs(Qi).eq.1).and.  &
25419                nstate(itypi,itypj).eq.1) THEN
25420 !c! Same charge-charge interaction ( +/+ or -/- )
25421           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25422             Qi=Qi*2
25423             Qij=Qij*2
25424            endif
25425           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25426             Qj=Qj*2
25427             Qij=Qij*2
25428            endif
25429
25430            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25431            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25432 !           eheadtail = 0.0d0
25433
25434           ELSE IF ((isel.eq.2.and.  &
25435                iabs(Qi).eq.1).and. &
25436                nstate(itypi,itypj).ne.1) THEN
25437 !c! Different charge-charge interaction ( +/- or -/+ )
25438           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25439             Qi=Qi*2
25440             Qij=Qij*2
25441            endif
25442           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25443             Qj=Qj*2
25444             Qij=Qij*2
25445            endif
25446
25447            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25448           END IF
25449        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25450       evdw = evdw  + Fcav + eheadtail
25451
25452        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25453         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25454         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25455         Equad,evdwij+Fcav+eheadtail,evdw
25456 !       evdw = evdw  + Fcav  + eheadtail
25457
25458         iF (nstate(itypi,itypj).eq.1) THEN
25459         CALL sc_grad
25460        END IF
25461 !c!-------------------------------------------------------------------
25462 !c! NAPISY KONCOWE
25463          END DO   ! j
25464         END DO    ! iint
25465        END DO     ! i
25466 !c      write (iout,*) "Number of loop steps in EGB:",ind
25467 !c      energy_dec=.false.
25468 !              print *,"EVDW KURW",evdw,nres
25469
25470        RETURN
25471       END SUBROUTINE emomo
25472 !C------------------------------------------------------------------------------------
25473       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25474       use calc_data
25475       use comm_momo
25476        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25477          Ecl,Egb,Epol,Fisocav,Elj,Fgb
25478 !       integer :: k
25479 !c! Epol and Gpol analytical parameters
25480        alphapol1 = alphapol(itypi,itypj)
25481        alphapol2 = alphapol(itypj,itypi)
25482 !c! Fisocav and Gisocav analytical parameters
25483        al1  = alphiso(1,itypi,itypj)
25484        al2  = alphiso(2,itypi,itypj)
25485        al3  = alphiso(3,itypi,itypj)
25486        al4  = alphiso(4,itypi,itypj)
25487        csig = (1.0d0  &
25488            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25489            + sigiso2(itypi,itypj)**2.0d0))
25490 !c!
25491        pis  = sig0head(itypi,itypj)
25492        eps_head = epshead(itypi,itypj)
25493        Rhead_sq = Rhead * Rhead
25494 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25495 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25496        R1 = 0.0d0
25497        R2 = 0.0d0
25498        DO k = 1, 3
25499 !c! Calculate head-to-tail distances needed by Epol
25500         R1=R1+(ctail(k,2)-chead(k,1))**2
25501         R2=R2+(chead(k,2)-ctail(k,1))**2
25502        END DO
25503 !c! Pitagoras
25504        R1 = dsqrt(R1)
25505        R2 = dsqrt(R2)
25506
25507 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25508 !c!     &        +dhead(1,1,itypi,itypj))**2))
25509 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25510 !c!     &        +dhead(2,1,itypi,itypj))**2))
25511
25512 !c!-------------------------------------------------------------------
25513 !c! Coulomb electrostatic interaction
25514        Ecl = (332.0d0 * Qij) / Rhead
25515 !c! derivative of Ecl is Gcl...
25516        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25517        dGCLdOM1 = 0.0d0
25518        dGCLdOM2 = 0.0d0
25519        dGCLdOM12 = 0.0d0
25520        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25521        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25522        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25523 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25524 !c! Derivative of Egb is Ggb...
25525        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25526        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25527        dGGBdR = dGGBdFGB * dFGBdR
25528 !c!-------------------------------------------------------------------
25529 !c! Fisocav - isotropic cavity creation term
25530 !c! or "how much energy it costs to put charged head in water"
25531        pom = Rhead * csig
25532        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25533        bot = (1.0d0 + al4 * pom**12.0d0)
25534        botsq = bot * bot
25535        FisoCav = top / bot
25536 !      write (*,*) "Rhead = ",Rhead
25537 !      write (*,*) "csig = ",csig
25538 !      write (*,*) "pom = ",pom
25539 !      write (*,*) "al1 = ",al1
25540 !      write (*,*) "al2 = ",al2
25541 !      write (*,*) "al3 = ",al3
25542 !      write (*,*) "al4 = ",al4
25543 !        write (*,*) "top = ",top
25544 !        write (*,*) "bot = ",bot
25545 !c! Derivative of Fisocav is GCV...
25546        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25547        dbot = 12.0d0 * al4 * pom ** 11.0d0
25548        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25549 !c!-------------------------------------------------------------------
25550 !c! Epol
25551 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25552        MomoFac1 = (1.0d0 - chi1 * sqom2)
25553        MomoFac2 = (1.0d0 - chi2 * sqom1)
25554        RR1  = ( R1 * R1 ) / MomoFac1
25555        RR2  = ( R2 * R2 ) / MomoFac2
25556        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25557        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25558        fgb1 = sqrt( RR1 + a12sq * ee1 )
25559        fgb2 = sqrt( RR2 + a12sq * ee2 )
25560        epol = 332.0d0 * eps_inout_fac * ( &
25561       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25562 !c!       epol = 0.0d0
25563        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25564                / (fgb1 ** 5.0d0)
25565        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25566                / (fgb2 ** 5.0d0)
25567        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25568              / ( 2.0d0 * fgb1 )
25569        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25570              / ( 2.0d0 * fgb2 )
25571        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25572                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25573        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25574                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25575        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25576 !c!       dPOLdR1 = 0.0d0
25577        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25578 !c!       dPOLdR2 = 0.0d0
25579        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25580 !c!       dPOLdOM1 = 0.0d0
25581        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25582 !c!       dPOLdOM2 = 0.0d0
25583 !c!-------------------------------------------------------------------
25584 !c! Elj
25585 !c! Lennard-Jones 6-12 interaction between heads
25586        pom = (pis / Rhead)**6.0d0
25587        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25588 !c! derivative of Elj is Glj
25589        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25590              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25591 !c!-------------------------------------------------------------------
25592 !c! Return the results
25593 !c! These things do the dRdX derivatives, that is
25594 !c! allow us to change what we see from function that changes with
25595 !c! distance to function that changes with LOCATION (of the interaction
25596 !c! site)
25597        DO k = 1, 3
25598         erhead(k) = Rhead_distance(k)/Rhead
25599         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25600         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25601        END DO
25602
25603        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25604        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25605        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25606        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25607        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25608        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25609        facd1 = d1 * vbld_inv(i+nres)
25610        facd2 = d2 * vbld_inv(j+nres)
25611        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25612        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25613
25614 !c! Now we add appropriate partial derivatives (one in each dimension)
25615        DO k = 1, 3
25616         hawk   = (erhead_tail(k,1) + &
25617         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25618         condor = (erhead_tail(k,2) + &
25619         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25620
25621         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25622         gvdwx(k,i) = gvdwx(k,i) &
25623                   - dGCLdR * pom&
25624                   - dGGBdR * pom&
25625                   - dGCVdR * pom&
25626                   - dPOLdR1 * hawk&
25627                   - dPOLdR2 * (erhead_tail(k,2)&
25628       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25629                   - dGLJdR * pom
25630
25631         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25632         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25633                    + dGGBdR * pom+ dGCVdR * pom&
25634                   + dPOLdR1 * (erhead_tail(k,1)&
25635       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25636                   + dPOLdR2 * condor + dGLJdR * pom
25637
25638         gvdwc(k,i) = gvdwc(k,i)  &
25639                   - dGCLdR * erhead(k)&
25640                   - dGGBdR * erhead(k)&
25641                   - dGCVdR * erhead(k)&
25642                   - dPOLdR1 * erhead_tail(k,1)&
25643                   - dPOLdR2 * erhead_tail(k,2)&
25644                   - dGLJdR * erhead(k)
25645
25646         gvdwc(k,j) = gvdwc(k,j)         &
25647                   + dGCLdR * erhead(k) &
25648                   + dGGBdR * erhead(k) &
25649                   + dGCVdR * erhead(k) &
25650                   + dPOLdR1 * erhead_tail(k,1) &
25651                   + dPOLdR2 * erhead_tail(k,2)&
25652                   + dGLJdR * erhead(k)
25653
25654        END DO
25655        RETURN
25656       END SUBROUTINE eqq
25657 !c!-------------------------------------------------------------------
25658       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25659       use comm_momo
25660       use calc_data
25661
25662        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
25663        double precision ener(4)
25664        double precision dcosom1(3),dcosom2(3)
25665 !c! used in Epol derivatives
25666        double precision facd3, facd4
25667        double precision federmaus, adler
25668        integer istate,ii,jj
25669        real (kind=8) :: Fgb
25670 !       print *,"CALLING EQUAD"
25671 !c! Epol and Gpol analytical parameters
25672        alphapol1 = alphapol(itypi,itypj)
25673        alphapol2 = alphapol(itypj,itypi)
25674 !c! Fisocav and Gisocav analytical parameters
25675        al1  = alphiso(1,itypi,itypj)
25676        al2  = alphiso(2,itypi,itypj)
25677        al3  = alphiso(3,itypi,itypj)
25678        al4  = alphiso(4,itypi,itypj)
25679        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25680             + sigiso2(itypi,itypj)**2.0d0))
25681 !c!
25682        w1   = wqdip(1,itypi,itypj)
25683        w2   = wqdip(2,itypi,itypj)
25684        pis  = sig0head(itypi,itypj)
25685        eps_head = epshead(itypi,itypj)
25686 !c! First things first:
25687 !c! We need to do sc_grad's job with GB and Fcav
25688        eom1  = eps2der * eps2rt_om1 &
25689              - 2.0D0 * alf1 * eps3der&
25690              + sigder * sigsq_om1&
25691              + dCAVdOM1
25692        eom2  = eps2der * eps2rt_om2 &
25693              + 2.0D0 * alf2 * eps3der&
25694              + sigder * sigsq_om2&
25695              + dCAVdOM2
25696        eom12 =  evdwij  * eps1_om12 &
25697              + eps2der * eps2rt_om12 &
25698              - 2.0D0 * alf12 * eps3der&
25699              + sigder *sigsq_om12&
25700              + dCAVdOM12
25701 !c! now some magical transformations to project gradient into
25702 !c! three cartesian vectors
25703        DO k = 1, 3
25704         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25705         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25706         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25707 !c! this acts on hydrophobic center of interaction
25708         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25709                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25710                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25711         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25712                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25713                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25714 !c! this acts on Calpha
25715         gvdwc(k,i)=gvdwc(k,i)-gg(k)
25716         gvdwc(k,j)=gvdwc(k,j)+gg(k)
25717        END DO
25718 !c! sc_grad is done, now we will compute
25719        eheadtail = 0.0d0
25720        eom1 = 0.0d0
25721        eom2 = 0.0d0
25722        eom12 = 0.0d0
25723        DO istate = 1, nstate(itypi,itypj)
25724 !c*************************************************************
25725         IF (istate.ne.1) THEN
25726          IF (istate.lt.3) THEN
25727           ii = 1
25728          ELSE
25729           ii = 2
25730          END IF
25731         jj = istate/ii
25732         d1 = dhead(1,ii,itypi,itypj)
25733         d2 = dhead(2,jj,itypi,itypj)
25734         DO k = 1,3
25735          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25736          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25737          Rhead_distance(k) = chead(k,2) - chead(k,1)
25738         END DO
25739 !c! pitagoras (root of sum of squares)
25740         Rhead = dsqrt( &
25741                (Rhead_distance(1)*Rhead_distance(1))  &
25742              + (Rhead_distance(2)*Rhead_distance(2))  &
25743              + (Rhead_distance(3)*Rhead_distance(3)))
25744         END IF
25745         Rhead_sq = Rhead * Rhead
25746
25747 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25748 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25749         R1 = 0.0d0
25750         R2 = 0.0d0
25751         DO k = 1, 3
25752 !c! Calculate head-to-tail distances
25753          R1=R1+(ctail(k,2)-chead(k,1))**2
25754          R2=R2+(chead(k,2)-ctail(k,1))**2
25755         END DO
25756 !c! Pitagoras
25757         R1 = dsqrt(R1)
25758         R2 = dsqrt(R2)
25759         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25760 !c!        Ecl = 0.0d0
25761 !c!        write (*,*) "Ecl = ", Ecl
25762 !c! derivative of Ecl is Gcl...
25763         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25764 !c!        dGCLdR = 0.0d0
25765         dGCLdOM1 = 0.0d0
25766         dGCLdOM2 = 0.0d0
25767         dGCLdOM12 = 0.0d0
25768 !c!-------------------------------------------------------------------
25769 !c! Generalised Born Solvent Polarization
25770         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25771         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25772         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25773 !c!        Egb = 0.0d0
25774 !c!      write (*,*) "a1*a2 = ", a12sq
25775 !c!      write (*,*) "Rhead = ", Rhead
25776 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25777 !c!      write (*,*) "ee = ", ee
25778 !c!      write (*,*) "Fgb = ", Fgb
25779 !c!      write (*,*) "fac = ", eps_inout_fac
25780 !c!      write (*,*) "Qij = ", Qij
25781 !c!      write (*,*) "Egb = ", Egb
25782 !c! Derivative of Egb is Ggb...
25783 !c! dFGBdR is used by Quad's later...
25784         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25785         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25786                / ( 2.0d0 * Fgb )
25787         dGGBdR = dGGBdFGB * dFGBdR
25788 !c!        dGGBdR = 0.0d0
25789 !c!-------------------------------------------------------------------
25790 !c! Fisocav - isotropic cavity creation term
25791         pom = Rhead * csig
25792         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25793         bot = (1.0d0 + al4 * pom**12.0d0)
25794         botsq = bot * bot
25795         FisoCav = top / bot
25796         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25797         dbot = 12.0d0 * al4 * pom ** 11.0d0
25798         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25799 !c!        dGCVdR = 0.0d0
25800 !c!-------------------------------------------------------------------
25801 !c! Polarization energy
25802 !c! Epol
25803         MomoFac1 = (1.0d0 - chi1 * sqom2)
25804         MomoFac2 = (1.0d0 - chi2 * sqom1)
25805         RR1  = ( R1 * R1 ) / MomoFac1
25806         RR2  = ( R2 * R2 ) / MomoFac2
25807         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25808         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25809         fgb1 = sqrt( RR1 + a12sq * ee1 )
25810         fgb2 = sqrt( RR2 + a12sq * ee2 )
25811         epol = 332.0d0 * eps_inout_fac * (&
25812         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25813 !c!        epol = 0.0d0
25814 !c! derivative of Epol is Gpol...
25815         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25816                   / (fgb1 ** 5.0d0)
25817         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25818                   / (fgb2 ** 5.0d0)
25819         dFGBdR1 = ( (R1 / MomoFac1) &
25820                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25821                 / ( 2.0d0 * fgb1 )
25822         dFGBdR2 = ( (R2 / MomoFac2) &
25823                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25824                 / ( 2.0d0 * fgb2 )
25825         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25826                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25827                  / ( 2.0d0 * fgb1 )
25828         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25829                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25830                  / ( 2.0d0 * fgb2 )
25831         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25832 !c!        dPOLdR1 = 0.0d0
25833         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25834 !c!        dPOLdR2 = 0.0d0
25835         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25836 !c!        dPOLdOM1 = 0.0d0
25837         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25838         pom = (pis / Rhead)**6.0d0
25839         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25840 !c!        Elj = 0.0d0
25841 !c! derivative of Elj is Glj
25842         dGLJdR = 4.0d0 * eps_head &
25843             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25844             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25845 !c!        dGLJdR = 0.0d0
25846 !c!-------------------------------------------------------------------
25847 !c! Equad
25848        IF (Wqd.ne.0.0d0) THEN
25849         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25850              - 37.5d0  * ( sqom1 + sqom2 ) &
25851              + 157.5d0 * ( sqom1 * sqom2 ) &
25852              - 45.0d0  * om1*om2*om12
25853         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25854         Equad = fac * Beta1
25855 !c!        Equad = 0.0d0
25856 !c! derivative of Equad...
25857         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25858 !c!        dQUADdR = 0.0d0
25859         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25860 !c!        dQUADdOM1 = 0.0d0
25861         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25862 !c!        dQUADdOM2 = 0.0d0
25863         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25864        ELSE
25865          Beta1 = 0.0d0
25866          Equad = 0.0d0
25867         END IF
25868 !c!-------------------------------------------------------------------
25869 !c! Return the results
25870 !c! Angular stuff
25871         eom1 = dPOLdOM1 + dQUADdOM1
25872         eom2 = dPOLdOM2 + dQUADdOM2
25873         eom12 = dQUADdOM12
25874 !c! now some magical transformations to project gradient into
25875 !c! three cartesian vectors
25876         DO k = 1, 3
25877          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25878          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25879          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25880         END DO
25881 !c! Radial stuff
25882         DO k = 1, 3
25883          erhead(k) = Rhead_distance(k)/Rhead
25884          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25885          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25886         END DO
25887         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25888         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25889         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25890         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25891         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25892         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25893         facd1 = d1 * vbld_inv(i+nres)
25894         facd2 = d2 * vbld_inv(j+nres)
25895         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25896         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25897         DO k = 1, 3
25898          hawk   = erhead_tail(k,1) + &
25899          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25900          condor = erhead_tail(k,2) + &
25901          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25902
25903          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25904 !c! this acts on hydrophobic center of interaction
25905          gheadtail(k,1,1) = gheadtail(k,1,1) &
25906                          - dGCLdR * pom &
25907                          - dGGBdR * pom &
25908                          - dGCVdR * pom &
25909                          - dPOLdR1 * hawk &
25910                          - dPOLdR2 * (erhead_tail(k,2) &
25911       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25912                          - dGLJdR * pom &
25913                          - dQUADdR * pom&
25914                          - tuna(k) &
25915                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25916                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25917
25918          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25919 !c! this acts on hydrophobic center of interaction
25920          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25921                          + dGCLdR * pom      &
25922                          + dGGBdR * pom      &
25923                          + dGCVdR * pom      &
25924                          + dPOLdR1 * (erhead_tail(k,1) &
25925       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25926                          + dPOLdR2 * condor &
25927                          + dGLJdR * pom &
25928                          + dQUADdR * pom &
25929                          + tuna(k) &
25930                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25931                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25932
25933 !c! this acts on Calpha
25934          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25935                          - dGCLdR * erhead(k)&
25936                          - dGGBdR * erhead(k)&
25937                          - dGCVdR * erhead(k)&
25938                          - dPOLdR1 * erhead_tail(k,1)&
25939                          - dPOLdR2 * erhead_tail(k,2)&
25940                          - dGLJdR * erhead(k) &
25941                          - dQUADdR * erhead(k)&
25942                          - tuna(k)
25943 !c! this acts on Calpha
25944          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25945                           + dGCLdR * erhead(k) &
25946                           + dGGBdR * erhead(k) &
25947                           + dGCVdR * erhead(k) &
25948                           + dPOLdR1 * erhead_tail(k,1) &
25949                           + dPOLdR2 * erhead_tail(k,2) &
25950                           + dGLJdR * erhead(k) &
25951                           + dQUADdR * erhead(k)&
25952                           + tuna(k)
25953         END DO
25954         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25955         eheadtail = eheadtail &
25956                   + wstate(istate, itypi, itypj) &
25957                   * dexp(-betaT * ener(istate))
25958 !c! foreach cartesian dimension
25959         DO k = 1, 3
25960 !c! foreach of two gvdwx and gvdwc
25961          DO l = 1, 4
25962           gheadtail(k,l,2) = gheadtail(k,l,2)  &
25963                            + wstate( istate, itypi, itypj ) &
25964                            * dexp(-betaT * ener(istate)) &
25965                            * gheadtail(k,l,1)
25966           gheadtail(k,l,1) = 0.0d0
25967          END DO
25968         END DO
25969        END DO
25970 !c! Here ended the gigantic DO istate = 1, 4, which starts
25971 !c! at the beggining of the subroutine
25972
25973        DO k = 1, 3
25974         DO l = 1, 4
25975          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
25976         END DO
25977         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
25978         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
25979         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
25980         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
25981         DO l = 1, 4
25982          gheadtail(k,l,1) = 0.0d0
25983          gheadtail(k,l,2) = 0.0d0
25984         END DO
25985        END DO
25986        eheadtail = (-dlog(eheadtail)) / betaT
25987        dPOLdOM1 = 0.0d0
25988        dPOLdOM2 = 0.0d0
25989        dQUADdOM1 = 0.0d0
25990        dQUADdOM2 = 0.0d0
25991        dQUADdOM12 = 0.0d0
25992        RETURN
25993       END SUBROUTINE energy_quad
25994 !!-----------------------------------------------------------
25995       SUBROUTINE eqn(Epol)
25996       use comm_momo
25997       use calc_data
25998
25999       double precision  facd4, federmaus,epol
26000       alphapol1 = alphapol(itypi,itypj)
26001 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26002        R1 = 0.0d0
26003        DO k = 1, 3
26004 !c! Calculate head-to-tail distances
26005         R1=R1+(ctail(k,2)-chead(k,1))**2
26006        END DO
26007 !c! Pitagoras
26008        R1 = dsqrt(R1)
26009
26010 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26011 !c!     &        +dhead(1,1,itypi,itypj))**2))
26012 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26013 !c!     &        +dhead(2,1,itypi,itypj))**2))
26014 !c--------------------------------------------------------------------
26015 !c Polarization energy
26016 !c Epol
26017        MomoFac1 = (1.0d0 - chi1 * sqom2)
26018        RR1  = R1 * R1 / MomoFac1
26019        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26020        fgb1 = sqrt( RR1 + a12sq * ee1)
26021        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26022        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26023                / (fgb1 ** 5.0d0)
26024        dFGBdR1 = ( (R1 / MomoFac1) &
26025               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26026               / ( 2.0d0 * fgb1 )
26027        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26028                 * (2.0d0 - 0.5d0 * ee1) ) &
26029                 / (2.0d0 * fgb1)
26030        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26031 !c!       dPOLdR1 = 0.0d0
26032        dPOLdOM1 = 0.0d0
26033        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26034        DO k = 1, 3
26035         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26036        END DO
26037        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26038        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26039        facd1 = d1 * vbld_inv(i+nres)
26040        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26041
26042        DO k = 1, 3
26043         hawk = (erhead_tail(k,1) + &
26044         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26045
26046         gvdwx(k,i) = gvdwx(k,i) &
26047                    - dPOLdR1 * hawk
26048         gvdwx(k,j) = gvdwx(k,j) &
26049                    + dPOLdR1 * (erhead_tail(k,1) &
26050        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26051
26052         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26053         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26054
26055        END DO
26056        RETURN
26057       END SUBROUTINE eqn
26058       SUBROUTINE enq(Epol)
26059       use calc_data
26060       use comm_momo
26061        double precision facd3, adler,epol
26062        alphapol2 = alphapol(itypj,itypi)
26063 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26064        R2 = 0.0d0
26065        DO k = 1, 3
26066 !c! Calculate head-to-tail distances
26067         R2=R2+(chead(k,2)-ctail(k,1))**2
26068        END DO
26069 !c! Pitagoras
26070        R2 = dsqrt(R2)
26071
26072 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26073 !c!     &        +dhead(1,1,itypi,itypj))**2))
26074 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26075 !c!     &        +dhead(2,1,itypi,itypj))**2))
26076 !c------------------------------------------------------------------------
26077 !c Polarization energy
26078        MomoFac2 = (1.0d0 - chi2 * sqom1)
26079        RR2  = R2 * R2 / MomoFac2
26080        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26081        fgb2 = sqrt(RR2  + a12sq * ee2)
26082        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26083        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26084                 / (fgb2 ** 5.0d0)
26085        dFGBdR2 = ( (R2 / MomoFac2)  &
26086               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26087               / (2.0d0 * fgb2)
26088        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26089                 * (2.0d0 - 0.5d0 * ee2) ) &
26090                 / (2.0d0 * fgb2)
26091        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26092 !c!       dPOLdR2 = 0.0d0
26093        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26094 !c!       dPOLdOM1 = 0.0d0
26095        dPOLdOM2 = 0.0d0
26096 !c!-------------------------------------------------------------------
26097 !c! Return the results
26098 !c! (See comments in Eqq)
26099        DO k = 1, 3
26100         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26101        END DO
26102        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26103        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26104        facd2 = d2 * vbld_inv(j+nres)
26105        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26106        DO k = 1, 3
26107         condor = (erhead_tail(k,2) &
26108        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26109
26110         gvdwx(k,i) = gvdwx(k,i) &
26111                    - dPOLdR2 * (erhead_tail(k,2) &
26112        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26113         gvdwx(k,j) = gvdwx(k,j)   &
26114                    + dPOLdR2 * condor
26115
26116         gvdwc(k,i) = gvdwc(k,i) &
26117                    - dPOLdR2 * erhead_tail(k,2)
26118         gvdwc(k,j) = gvdwc(k,j) &
26119                    + dPOLdR2 * erhead_tail(k,2)
26120
26121        END DO
26122       RETURN
26123       END SUBROUTINE enq
26124       SUBROUTINE eqd(Ecl,Elj,Epol)
26125       use calc_data
26126       use comm_momo
26127        double precision  facd4, federmaus,ecl,elj,epol
26128        alphapol1 = alphapol(itypi,itypj)
26129        w1        = wqdip(1,itypi,itypj)
26130        w2        = wqdip(2,itypi,itypj)
26131        pis       = sig0head(itypi,itypj)
26132        eps_head   = epshead(itypi,itypj)
26133 !c!-------------------------------------------------------------------
26134 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26135        R1 = 0.0d0
26136        DO k = 1, 3
26137 !c! Calculate head-to-tail distances
26138         R1=R1+(ctail(k,2)-chead(k,1))**2
26139        END DO
26140 !c! Pitagoras
26141        R1 = dsqrt(R1)
26142
26143 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26144 !c!     &        +dhead(1,1,itypi,itypj))**2))
26145 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26146 !c!     &        +dhead(2,1,itypi,itypj))**2))
26147
26148 !c!-------------------------------------------------------------------
26149 !c! ecl
26150        sparrow  = w1 * Qi * om1
26151        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26152        Ecl = sparrow / Rhead**2.0d0 &
26153            - hawk    / Rhead**4.0d0
26154        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26155                  + 4.0d0 * hawk    / Rhead**5.0d0
26156 !c! dF/dom1
26157        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26158 !c! dF/dom2
26159        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26160 !c--------------------------------------------------------------------
26161 !c Polarization energy
26162 !c Epol
26163        MomoFac1 = (1.0d0 - chi1 * sqom2)
26164        RR1  = R1 * R1 / MomoFac1
26165        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26166        fgb1 = sqrt( RR1 + a12sq * ee1)
26167        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26168 !c!       epol = 0.0d0
26169 !c!------------------------------------------------------------------
26170 !c! derivative of Epol is Gpol...
26171        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26172                / (fgb1 ** 5.0d0)
26173        dFGBdR1 = ( (R1 / MomoFac1)  &
26174              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26175              / ( 2.0d0 * fgb1 )
26176        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26177                * (2.0d0 - 0.5d0 * ee1) ) &
26178                / (2.0d0 * fgb1)
26179        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26180 !c!       dPOLdR1 = 0.0d0
26181        dPOLdOM1 = 0.0d0
26182        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26183 !c!       dPOLdOM2 = 0.0d0
26184 !c!-------------------------------------------------------------------
26185 !c! Elj
26186        pom = (pis / Rhead)**6.0d0
26187        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26188 !c! derivative of Elj is Glj
26189        dGLJdR = 4.0d0 * eps_head &
26190           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26191           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26192        DO k = 1, 3
26193         erhead(k) = Rhead_distance(k)/Rhead
26194         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26195        END DO
26196
26197        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26198        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26199        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26200        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26201        facd1 = d1 * vbld_inv(i+nres)
26202        facd2 = d2 * vbld_inv(j+nres)
26203        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26204
26205        DO k = 1, 3
26206         hawk = (erhead_tail(k,1) +  &
26207         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26208
26209         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26210         gvdwx(k,i) = gvdwx(k,i)  &
26211                    - dGCLdR * pom&
26212                    - dPOLdR1 * hawk &
26213                    - dGLJdR * pom
26214
26215         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26216         gvdwx(k,j) = gvdwx(k,j)    &
26217                    + dGCLdR * pom  &
26218                    + dPOLdR1 * (erhead_tail(k,1) &
26219        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26220                    + dGLJdR * pom
26221
26222
26223         gvdwc(k,i) = gvdwc(k,i)          &
26224                    - dGCLdR * erhead(k)  &
26225                    - dPOLdR1 * erhead_tail(k,1) &
26226                    - dGLJdR * erhead(k)
26227
26228         gvdwc(k,j) = gvdwc(k,j)          &
26229                    + dGCLdR * erhead(k)  &
26230                    + dPOLdR1 * erhead_tail(k,1) &
26231                    + dGLJdR * erhead(k)
26232
26233        END DO
26234        RETURN
26235       END SUBROUTINE eqd
26236       SUBROUTINE edq(Ecl,Elj,Epol)
26237 !       IMPLICIT NONE
26238        use comm_momo
26239       use calc_data
26240
26241       double precision  facd3, adler,ecl,elj,epol
26242        alphapol2 = alphapol(itypj,itypi)
26243        w1        = wqdip(1,itypi,itypj)
26244        w2        = wqdip(2,itypi,itypj)
26245        pis       = sig0head(itypi,itypj)
26246        eps_head  = epshead(itypi,itypj)
26247 !c!-------------------------------------------------------------------
26248 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26249        R2 = 0.0d0
26250        DO k = 1, 3
26251 !c! Calculate head-to-tail distances
26252         R2=R2+(chead(k,2)-ctail(k,1))**2
26253        END DO
26254 !c! Pitagoras
26255        R2 = dsqrt(R2)
26256
26257 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26258 !c!     &        +dhead(1,1,itypi,itypj))**2))
26259 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26260 !c!     &        +dhead(2,1,itypi,itypj))**2))
26261
26262
26263 !c!-------------------------------------------------------------------
26264 !c! ecl
26265        sparrow  = w1 * Qi * om1
26266        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26267        ECL = sparrow / Rhead**2.0d0 &
26268            - hawk    / Rhead**4.0d0
26269 !c!-------------------------------------------------------------------
26270 !c! derivative of ecl is Gcl
26271 !c! dF/dr part
26272        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26273                  + 4.0d0 * hawk    / Rhead**5.0d0
26274 !c! dF/dom1
26275        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26276 !c! dF/dom2
26277        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26278 !c--------------------------------------------------------------------
26279 !c Polarization energy
26280 !c Epol
26281        MomoFac2 = (1.0d0 - chi2 * sqom1)
26282        RR2  = R2 * R2 / MomoFac2
26283        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26284        fgb2 = sqrt(RR2  + a12sq * ee2)
26285        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26286        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26287                / (fgb2 ** 5.0d0)
26288        dFGBdR2 = ( (R2 / MomoFac2)  &
26289                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26290                / (2.0d0 * fgb2)
26291        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26292                 * (2.0d0 - 0.5d0 * ee2) ) &
26293                 / (2.0d0 * fgb2)
26294        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26295 !c!       dPOLdR2 = 0.0d0
26296        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26297 !c!       dPOLdOM1 = 0.0d0
26298        dPOLdOM2 = 0.0d0
26299 !c!-------------------------------------------------------------------
26300 !c! Elj
26301        pom = (pis / Rhead)**6.0d0
26302        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26303 !c! derivative of Elj is Glj
26304        dGLJdR = 4.0d0 * eps_head &
26305            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26306            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26307 !c!-------------------------------------------------------------------
26308 !c! Return the results
26309 !c! (see comments in Eqq)
26310        DO k = 1, 3
26311         erhead(k) = Rhead_distance(k)/Rhead
26312         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26313        END DO
26314        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26315        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26316        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26317        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26318        facd1 = d1 * vbld_inv(i+nres)
26319        facd2 = d2 * vbld_inv(j+nres)
26320        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26321        DO k = 1, 3
26322         condor = (erhead_tail(k,2) &
26323        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26324
26325         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26326         gvdwx(k,i) = gvdwx(k,i) &
26327                   - dGCLdR * pom &
26328                   - dPOLdR2 * (erhead_tail(k,2) &
26329        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26330                   - dGLJdR * pom
26331
26332         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26333         gvdwx(k,j) = gvdwx(k,j) &
26334                   + dGCLdR * pom &
26335                   + dPOLdR2 * condor &
26336                   + dGLJdR * pom
26337
26338
26339         gvdwc(k,i) = gvdwc(k,i) &
26340                   - dGCLdR * erhead(k) &
26341                   - dPOLdR2 * erhead_tail(k,2) &
26342                   - dGLJdR * erhead(k)
26343
26344         gvdwc(k,j) = gvdwc(k,j) &
26345                   + dGCLdR * erhead(k) &
26346                   + dPOLdR2 * erhead_tail(k,2) &
26347                   + dGLJdR * erhead(k)
26348
26349        END DO
26350        RETURN
26351       END SUBROUTINE edq
26352       SUBROUTINE edd(ECL)
26353 !       IMPLICIT NONE
26354        use comm_momo
26355       use calc_data
26356
26357        double precision ecl
26358 !c!       csig = sigiso(itypi,itypj)
26359        w1 = wqdip(1,itypi,itypj)
26360        w2 = wqdip(2,itypi,itypj)
26361 !c!-------------------------------------------------------------------
26362 !c! ECL
26363        fac = (om12 - 3.0d0 * om1 * om2)
26364        c1 = (w1 / (Rhead**3.0d0)) * fac
26365        c2 = (w2 / Rhead ** 6.0d0) &
26366           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26367        ECL = c1 - c2
26368 !c!       write (*,*) "w1 = ", w1
26369 !c!       write (*,*) "w2 = ", w2
26370 !c!       write (*,*) "om1 = ", om1
26371 !c!       write (*,*) "om2 = ", om2
26372 !c!       write (*,*) "om12 = ", om12
26373 !c!       write (*,*) "fac = ", fac
26374 !c!       write (*,*) "c1 = ", c1
26375 !c!       write (*,*) "c2 = ", c2
26376 !c!       write (*,*) "Ecl = ", Ecl
26377 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
26378 !c!       write (*,*) "c2_2 = ",
26379 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26380 !c!-------------------------------------------------------------------
26381 !c! dervative of ECL is GCL...
26382 !c! dECL/dr
26383        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26384        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26385           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26386        dGCLdR = c1 - c2
26387 !c! dECL/dom1
26388        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26389        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26390           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26391        dGCLdOM1 = c1 - c2
26392 !c! dECL/dom2
26393        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26394        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26395           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26396        dGCLdOM2 = c1 - c2
26397 !c! dECL/dom12
26398        c1 = w1 / (Rhead ** 3.0d0)
26399        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26400        dGCLdOM12 = c1 - c2
26401 !c!-------------------------------------------------------------------
26402 !c! Return the results
26403 !c! (see comments in Eqq)
26404        DO k= 1, 3
26405         erhead(k) = Rhead_distance(k)/Rhead
26406        END DO
26407        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26408        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26409        facd1 = d1 * vbld_inv(i+nres)
26410        facd2 = d2 * vbld_inv(j+nres)
26411        DO k = 1, 3
26412
26413         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26414         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
26415         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26416         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
26417
26418         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
26419         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
26420        END DO
26421        RETURN
26422       END SUBROUTINE edd
26423       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26424 !       IMPLICIT NONE
26425        use comm_momo
26426       use calc_data
26427
26428        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
26429        eps_out=80.0d0
26430        itypi = itype(i,1)
26431        itypj = itype(j,1)
26432 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
26433 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
26434 !c!       t_bath = 300
26435 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
26436        Rb=0.001986d0
26437        BetaT = 1.0d0 / (298.0d0 * Rb)
26438 !c! Gay-berne var's
26439        sig0ij = sigma( itypi,itypj )
26440        chi1   = chi( itypi, itypj )
26441        chi2   = chi( itypj, itypi )
26442        chi12  = chi1 * chi2
26443        chip1  = chipp( itypi, itypj )
26444        chip2  = chipp( itypj, itypi )
26445        chip12 = chip1 * chip2
26446 !       chi1=0.0
26447 !       chi2=0.0
26448 !       chi12=0.0
26449 !       chip1=0.0
26450 !       chip2=0.0
26451 !       chip12=0.0
26452 !c! not used by momo potential, but needed by sc_angular which is shared
26453 !c! by all energy_potential subroutines
26454        alf1   = 0.0d0
26455        alf2   = 0.0d0
26456        alf12  = 0.0d0
26457 !c! location, location, location
26458 !       xj  = c( 1, nres+j ) - xi
26459 !       yj  = c( 2, nres+j ) - yi
26460 !       zj  = c( 3, nres+j ) - zi
26461        dxj = dc_norm( 1, nres+j )
26462        dyj = dc_norm( 2, nres+j )
26463        dzj = dc_norm( 3, nres+j )
26464 !c! distance from center of chain(?) to polar/charged head
26465 !c!       write (*,*) "istate = ", 1
26466 !c!       write (*,*) "ii = ", 1
26467 !c!       write (*,*) "jj = ", 1
26468        d1 = dhead(1, 1, itypi, itypj)
26469        d2 = dhead(2, 1, itypi, itypj)
26470 !c! ai*aj from Fgb
26471        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26472 !c!       a12sq = a12sq * a12sq
26473 !c! charge of amino acid itypi is...
26474        Qi  = icharge(itypi)
26475        Qj  = icharge(itypj)
26476        Qij = Qi * Qj
26477 !c! chis1,2,12
26478        chis1 = chis(itypi,itypj)
26479        chis2 = chis(itypj,itypi)
26480        chis12 = chis1 * chis2
26481        sig1 = sigmap1(itypi,itypj)
26482        sig2 = sigmap2(itypi,itypj)
26483 !c!       write (*,*) "sig1 = ", sig1
26484 !c!       write (*,*) "sig2 = ", sig2
26485 !c! alpha factors from Fcav/Gcav
26486        b1cav = alphasur(1,itypi,itypj)
26487 !       b1cav=0.0
26488        b2cav = alphasur(2,itypi,itypj)
26489        b3cav = alphasur(3,itypi,itypj)
26490        b4cav = alphasur(4,itypi,itypj)
26491        wqd = wquad(itypi, itypj)
26492 !c! used by Fgb
26493        eps_in = epsintab(itypi,itypj)
26494        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26495 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
26496 !c!-------------------------------------------------------------------
26497 !c! tail location and distance calculations
26498        Rtail = 0.0d0
26499        DO k = 1, 3
26500         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26501         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26502        END DO
26503 !c! tail distances will be themselves usefull elswhere
26504 !c1 (in Gcav, for example)
26505        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26506        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26507        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26508        Rtail = dsqrt(  &
26509           (Rtail_distance(1)*Rtail_distance(1))  &
26510         + (Rtail_distance(2)*Rtail_distance(2))  &
26511         + (Rtail_distance(3)*Rtail_distance(3)))
26512 !c!-------------------------------------------------------------------
26513 !c! Calculate location and distance between polar heads
26514 !c! distance between heads
26515 !c! for each one of our three dimensional space...
26516        d1 = dhead(1, 1, itypi, itypj)
26517        d2 = dhead(2, 1, itypi, itypj)
26518
26519        DO k = 1,3
26520 !c! location of polar head is computed by taking hydrophobic centre
26521 !c! and moving by a d1 * dc_norm vector
26522 !c! see unres publications for very informative images
26523         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26524         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26525 !c! distance
26526 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26527 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26528         Rhead_distance(k) = chead(k,2) - chead(k,1)
26529        END DO
26530 !c! pitagoras (root of sum of squares)
26531        Rhead = dsqrt(   &
26532           (Rhead_distance(1)*Rhead_distance(1)) &
26533         + (Rhead_distance(2)*Rhead_distance(2)) &
26534         + (Rhead_distance(3)*Rhead_distance(3)))
26535 !c!-------------------------------------------------------------------
26536 !c! zero everything that should be zero'ed
26537        Egb = 0.0d0
26538        ECL = 0.0d0
26539        Elj = 0.0d0
26540        Equad = 0.0d0
26541        Epol = 0.0d0
26542        eheadtail = 0.0d0
26543        dGCLdOM1 = 0.0d0
26544        dGCLdOM2 = 0.0d0
26545        dGCLdOM12 = 0.0d0
26546        dPOLdOM1 = 0.0d0
26547        dPOLdOM2 = 0.0d0
26548        RETURN
26549       END SUBROUTINE elgrad_init
26550
26551       double precision function tschebyshev(m,n,x,y)
26552       implicit none
26553       integer i,m,n
26554       double precision x(n),y,yy(0:maxvar),aux
26555 !c Tschebyshev polynomial. Note that the first term is omitted
26556 !c m=0: the constant term is included
26557 !c m=1: the constant term is not included
26558       yy(0)=1.0d0
26559       yy(1)=y
26560       do i=2,n
26561         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
26562       enddo
26563       aux=0.0d0
26564       do i=m,n
26565         aux=aux+x(i)*yy(i)
26566       enddo
26567       tschebyshev=aux
26568       return
26569       end function tschebyshev
26570 !C--------------------------------------------------------------------------
26571       double precision function gradtschebyshev(m,n,x,y)
26572       implicit none
26573       integer i,m,n
26574       double precision x(n+1),y,yy(0:maxvar),aux
26575 !c Tschebyshev polynomial. Note that the first term is omitted
26576 !c m=0: the constant term is included
26577 !c m=1: the constant term is not included
26578       yy(0)=1.0d0
26579       yy(1)=2.0d0*y
26580       do i=2,n
26581         yy(i)=2*y*yy(i-1)-yy(i-2)
26582       enddo
26583       aux=0.0d0
26584       do i=m,n
26585         aux=aux+x(i+1)*yy(i)*(i+1)
26586 !C        print *, x(i+1),yy(i),i
26587       enddo
26588       gradtschebyshev=aux
26589       return
26590       end function gradtschebyshev
26591
26592
26593
26594
26595
26596       end module energy