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,imatupdate
 240       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 241       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 242       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 243                       Eafmforce,ethetacnstr
 244       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 245 ! now energies for nulceic alone parameters
 246       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 247                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 248                       ecorr3_nucl
 249 ! energies for ions
 250       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
 251 ! energies for protein nucleic acid interaction
 252       real(kind=8) :: escbase,epepbase,escpho,epeppho
 253
 254 #ifdef MPI
 255       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 256 ! shielding effect varibles for MPI
 257       real(kind=8) ::  fac_shieldbuf(nres), &
 258       grad_shield_locbuf1(3*maxcontsshi*nres), &
 259       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 260       grad_shield_locbuf2(3*maxcontsshi*nres), &
 261       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 262       grad_shieldbuf1(3*nres), &
 263       grad_shieldbuf2(3*nres)
 264
 265        integer ishield_listbuf(-1:nres), &
 266        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 267 !       print *,"I START ENERGY"
 268        imatupdate=100
 269 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 270 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 271 !      real(kind=8), dimension(:,:,:),allocatable:: &
 272 !       grad_shield_locbuf,grad_shield_sidebuf
 273 !      real(kind=8), dimension(:,:),allocatable:: &
 274 !        grad_shieldbuf
 275 !       integer, dimension(:),allocatable:: &
 276 !       ishield_listbuf
 277 !       integer, dimension(:,:),allocatable::  shield_listbuf
 278 !       integer :: k,j,i
 279 !      if (.not.allocated(fac_shieldbuf)) then
 280 !          allocate(fac_shieldbuf(nres))
 281 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 282 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 283 !          allocate(grad_shieldbuf(3,-1:nres))
 284 !          allocate(ishield_listbuf(nres))
 285 !          allocate(shield_listbuf(maxcontsshi,nres))
 286 !       endif
 287
 288 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 289 !     & " nfgtasks",nfgtasks
 290       if (nfgtasks.gt.1) then
 291         time00=MPI_Wtime()
 292 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 293         if (fg_rank.eq.0) then
 294           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 295 !          print *,"Processor",myrank," BROADCAST iorder"
 296 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 297 ! FG slaves as WEIGHTS array.
 298           weights_(1)=wsc
 299           weights_(2)=wscp
 300           weights_(3)=welec
 301           weights_(4)=wcorr
 302           weights_(5)=wcorr5
 303           weights_(6)=wcorr6
 304           weights_(7)=wel_loc
 305           weights_(8)=wturn3
 306           weights_(9)=wturn4
 307           weights_(10)=wturn6
 308           weights_(11)=wang
 309           weights_(12)=wscloc
 310           weights_(13)=wtor
 311           weights_(14)=wtor_d
 312           weights_(15)=wstrain
 313           weights_(16)=wvdwpp
 314           weights_(17)=wbond
 315           weights_(18)=scal14
 316           weights_(21)=wsccor
 317           weights_(26)=wvdwpp_nucl
 318           weights_(27)=welpp
 319           weights_(28)=wvdwpsb
 320           weights_(29)=welpsb
 321           weights_(30)=wvdwsb
 322           weights_(31)=welsb
 323           weights_(32)=wbond_nucl
 324           weights_(33)=wang_nucl
 325           weights_(34)=wsbloc
 326           weights_(35)=wtor_nucl
 327           weights_(36)=wtor_d_nucl
 328           weights_(37)=wcorr_nucl
 329           weights_(38)=wcorr3_nucl
 330           weights_(41)=wcatcat
 331           weights_(42)=wcatprot
 332           weights_(46)=wscbase
 333           weights_(47)=wpepbase
 334           weights_(48)=wscpho
 335           weights_(49)=wpeppho
 336 !          wcatcat= weights(41)
 337 !          wcatprot=weights(42)
 338
 339 ! FG Master broadcasts the WEIGHTS_ array
 340           call MPI_Bcast(weights_(1),n_ene,&
 341              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 342         else
 343 ! FG slaves receive the WEIGHTS array
 344           call MPI_Bcast(weights(1),n_ene,&
 345               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 346           wsc=weights(1)
 347           wscp=weights(2)
 348           welec=weights(3)
 349           wcorr=weights(4)
 350           wcorr5=weights(5)
 351           wcorr6=weights(6)
 352           wel_loc=weights(7)
 353           wturn3=weights(8)
 354           wturn4=weights(9)
 355           wturn6=weights(10)
 356           wang=weights(11)
 357           wscloc=weights(12)
 358           wtor=weights(13)
 359           wtor_d=weights(14)
 360           wstrain=weights(15)
 361           wvdwpp=weights(16)
 362           wbond=weights(17)
 363           scal14=weights(18)
 364           wsccor=weights(21)
 365           wvdwpp_nucl =weights(26)
 366           welpp  =weights(27)
 367           wvdwpsb=weights(28)
 368           welpsb =weights(29)
 369           wvdwsb =weights(30)
 370           welsb  =weights(31)
 371           wbond_nucl  =weights(32)
 372           wang_nucl   =weights(33)
 373           wsbloc =weights(34)
 374           wtor_nucl   =weights(35)
 375           wtor_d_nucl =weights(36)
 376           wcorr_nucl  =weights(37)
 377           wcorr3_nucl =weights(38)
 378           wcatcat= weights(41)
 379           wcatprot=weights(42)
 380           wscbase=weights(46)
 381           wpepbase=weights(47)
 382           wscpho=weights(48)
 383           wpeppho=weights(49)
 384 !      welpsb=weights(28)*fact(1)
 385 !
 386 !      wcorr_nucl= weights(37)*fact(1)
 387 !     wcorr3_nucl=weights(38)*fact(2)
 388 !     wtor_nucl=  weights(35)*fact(1)
 389 !     wtor_d_nucl=weights(36)*fact(2)
 390
 391         endif
 392         time_Bcast=time_Bcast+MPI_Wtime()-time00
 393         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 394 !        call chainbuild_cart
 395       endif
 396 !       print *,"itime_mat",itime_mat,imatupdate
 397         if (nfgtasks.gt.1) then
 398         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 399         endif
 400        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 401        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 402        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 403
 404 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 405 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 406 #else
 407 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 408 !        call int_from_cart1(.false.)
 409 !      endif
 410 #endif
 411 #ifdef TIMING
 412       time00=MPI_Wtime()
 413 #endif
 414 !
 415 ! Compute the side-chain and electrostatic interaction energy
 416 !        print *, "Before EVDW"
 417 !      goto (101,102,103,104,105,106) ipot
 418       select case(ipot)
 419 ! Lennard-Jones potential.
 420 !  101 call elj(evdw)
 421        case (1)
 422          call elj(evdw)
 423 !d    print '(a)','Exit ELJcall el'
 424 !      goto 107
 425 ! Lennard-Jones-Kihara potential (shifted).
 426 !  102 call eljk(evdw)
 427        case (2)
 428          call eljk(evdw)
 429 !      goto 107
 430 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 431 !  103 call ebp(evdw)
 432        case (3)
 433          call ebp(evdw)
 434 !      goto 107
 435 ! Gay-Berne potential (shifted LJ, angular dependence).
 436 !  104 call egb(evdw)
 437        case (4)
 438 !       print *,"MOMO",scelemode
 439         if (scelemode.eq.0) then
 440          call egb(evdw)
 441         else
 442          call emomo(evdw)
 443         endif
 444 !      goto 107
 445 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 446 !  105 call egbv(evdw)
 447        case (5)
 448          call egbv(evdw)
 449 !      goto 107
 450 ! Soft-sphere potential
 451 !  106 call e_softsphere(evdw)
 452        case (6)
 453          call e_softsphere(evdw)
 454 !
 455 ! Calculate electrostatic (H-bonding) energy of the main chain.
 456 !
 457 !  107 continue
 458        case default
 459          write(iout,*)"Wrong ipot"
 460 !         return
 461 !   50 continue
 462       end select
 463 !      continue
 464 !        print *,"after EGB"
 465 ! shielding effect
 466        if (shield_mode.eq.2) then
 467                  call set_shield_fac2
 468
 469       if (nfgtasks.gt.1) then
 470       grad_shield_sidebuf1(:)=0.0d0
 471       grad_shield_locbuf1(:)=0.0d0
 472       grad_shield_sidebuf2(:)=0.0d0
 473       grad_shield_locbuf2(:)=0.0d0
 474       grad_shieldbuf1(:)=0.0d0
 475       grad_shieldbuf2(:)=0.0d0
 476 !#define DEBUG
 477 #ifdef DEBUG
 478        write(iout,*) "befor reduce fac_shield reduce"
 479        do i=1,nres
 480         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 481         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 482        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 483        enddo
 484 #endif
 485         iii=0
 486         jjj=0
 487         do i=1,nres
 488         ishield_listbuf(i)=0
 489         do k=1,3
 490         iii=iii+1
 491         grad_shieldbuf1(iii)=grad_shield(k,i)
 492         enddo
 493         enddo
 494         do i=1,nres
 495          do j=1,maxcontsshi
 496           do k=1,3
 497               jjj=jjj+1
 498               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 499               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 500            enddo
 501           enddo
 502          enddo
 503         call MPI_Allgatherv(fac_shield(ivec_start), &
 504         ivec_count(fg_rank1), &
 505         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 506         ivec_displ(0), &
 507         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 508         call MPI_Allgatherv(shield_list(1,ivec_start), &
 509         ivec_count(fg_rank1), &
 510         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 511         ivec_displ(0), &
 512         MPI_I50,FG_COMM,IERROR)
 513 !        write(2,*) "After I50"
 514 !        call flush(iout)
 515         call MPI_Allgatherv(ishield_list(ivec_start), &
 516         ivec_count(fg_rank1), &
 517         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 518         ivec_displ(0), &
 519         MPI_INTEGER,FG_COMM,IERROR)
 520 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 521
 522 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 523 !        write (2,*) "before"
 524 !        write(2,*) grad_shieldbuf1
 525 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 526 !        ivec_count(fg_rank1)*3, &
 527 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 528 !        ivec_count(0), &
 529 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 530         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 531         nres*3, &
 532         MPI_DOUBLE_PRECISION, &
 533         MPI_SUM, &
 534         FG_COMM,IERROR)
 535         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 536         nres*3*maxcontsshi, &
 537         MPI_DOUBLE_PRECISION, &
 538         MPI_SUM, &
 539         FG_COMM,IERROR)
 540
 541         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 542         nres*3*maxcontsshi, &
 543         MPI_DOUBLE_PRECISION, &
 544         MPI_SUM, &
 545         FG_COMM,IERROR)
 546
 547 !        write(2,*) "after"
 548 !        write(2,*) grad_shieldbuf2
 549
 550 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 551 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 552 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 553 !        ivec_displ(0)*3*maxcontsshi, &
 554 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 555 !        write(2,*) "After grad_shield_side"
 556 !        call flush(iout)
 557 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 558 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 559 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 560 !        ivec_displ(0)*3*maxcontsshi, &
 561 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 562 !        write(2,*) "After MPI_SHI"
 563 !        call flush(iout)
 564         iii=0
 565         jjj=0
 566         do i=1,nres
 567          fac_shield(i)=fac_shieldbuf(i)
 568          ishield_list(i)=ishield_listbuf(i)
 569 !         write(iout,*) i,fac_shield(i)
 570          do j=1,3
 571          iii=iii+1
 572          grad_shield(j,i)=grad_shieldbuf2(iii)
 573          enddo !j
 574          do j=1,ishield_list(i)
 575 !          write (iout,*) "ishild", ishield_list(i),i
 576            shield_list(j,i)=shield_listbuf(j,i)
 577           enddo
 578           do j=1,maxcontsshi
 579           do k=1,3
 580            jjj=jjj+1
 581           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 582           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 583           enddo !k
 584         enddo !j
 585        enddo !i
 586        endif
 587 #ifdef DEBUG
 588        write(iout,*) "after reduce fac_shield reduce"
 589        do i=1,nres
 590         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 591         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 592         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 593        enddo
 594 #endif
 595 #undef DEBUG
 596        endif
 597
 598
 599
 600 !       print *,"AFTER EGB",ipot,evdw
 601 !mc
 602 !mc Sep-06: egb takes care of dynamic ss bonds too
 603 !mc
 604 !      if (dyn_ss) call dyn_set_nss
 605 !      print *,"Processor",myrank," computed USCSC"
 606 #ifdef TIMING
 607       time01=MPI_Wtime()
 608 #endif
 609       call vec_and_deriv
 610 #ifdef TIMING
 611       time_vec=time_vec+MPI_Wtime()-time01
 612 #endif
 613
 614
 615
 616
 617 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 618       if (ipot.lt.6) then
 619 #ifdef SPLITELE
 620 !         print *,"after ipot if", ipot
 621          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 622              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 623              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 624              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 625 #else
 626          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 627              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 628              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 629              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 630 #endif
 631 !            print *,"just befor eelec call"
 632             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 633 !            print *, "ELEC calc"
 634          else
 635             ees=0.0d0
 636             evdw1=0.0d0
 637             eel_loc=0.0d0
 638             eello_turn3=0.0d0
 639             eello_turn4=0.0d0
 640          endif
 641       else
 642 !        write (iout,*) "Soft-spheer ELEC potential"
 643         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 644          eello_turn4)
 645       endif
 646 !      print *,"Processor",myrank," computed UELEC"
 647 !
 648 ! Calculate excluded-volume interaction energy between peptide groups
 649 ! and side chains.
 650 !
 651 !       write(iout,*) "in etotal calc exc;luded",ipot
 652
 653       if (ipot.lt.6) then
 654        if(wscp.gt.0d0) then
 655         call escp(evdw2,evdw2_14)
 656        else
 657         evdw2=0
 658         evdw2_14=0
 659        endif
 660       else
 661 !        write (iout,*) "Soft-sphere SCP potential"
 662         call escp_soft_sphere(evdw2,evdw2_14)
 663       endif
 664 !        write(iout,*) "in etotal before ebond",ipot
 665
 666 !
 667 ! Calculate the bond-stretching energy
 668 !
 669       call ebond(estr)
 670 !       print *,"EBOND",estr
 671 !       write(iout,*) "in etotal afer ebond",ipot
 672
 673 !
 674 ! Calculate the disulfide-bridge and other energy and the contributions
 675 ! from other distance constraints.
 676 !      print *,'Calling EHPB'
 677       call edis(ehpb)
 678 !elwrite(iout,*) "in etotal afer edis",ipot
 679 !      print *,'EHPB exitted succesfully.'
 680 !
 681 ! Calculate the virtual-bond-angle energy.
 682 !       write(iout,*) "in etotal afer edis",ipot
 683
 684 !      if (wang.gt.0.0d0) then
 685 !        call ebend(ebe,ethetacnstr)
 686 !      else
 687 !        ebe=0
 688 !        ethetacnstr=0
 689 !      endif
 690       if (wang.gt.0d0) then
 691        if (tor_mode.eq.0) then
 692          call ebend(ebe)
 693        else
 694 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 695 !C energy function
 696          call ebend_kcc(ebe)
 697        endif
 698       else
 699         ebe=0.0d0
 700       endif
 701       ethetacnstr=0.0d0
 702       if (with_theta_constr) call etheta_constr(ethetacnstr)
 703
 704 !       write(iout,*) "in etotal afer ebe",ipot
 705
 706 !      print *,"Processor",myrank," computed UB"
 707 !
 708 ! Calculate the SC local energy.
 709 !
 710       call esc(escloc)
 711 !elwrite(iout,*) "in etotal afer esc",ipot
 712 !      print *,"Processor",myrank," computed USC"
 713 !
 714 ! Calculate the virtual-bond torsional energy.
 715 !
 716 !d    print *,'nterm=',nterm
 717 !      if (wtor.gt.0) then
 718 !       call etor(etors,edihcnstr)
 719 !      else
 720 !       etors=0
 721 !       edihcnstr=0
 722 !      endif
 723       if (wtor.gt.0.0d0) then
 724          if (tor_mode.eq.0) then
 725            call etor(etors)
 726          else
 727 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 728 !C energy function
 729            call etor_kcc(etors)
 730          endif
 731       else
 732         etors=0.0d0
 733       endif
 734       edihcnstr=0.0d0
 735       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 736 !c      print *,"Processor",myrank," computed Utor"
 737
 738 !      print *,"Processor",myrank," computed Utor"
 739
 740 !
 741 ! 6/23/01 Calculate double-torsional energy
 742 !
 743 !elwrite(iout,*) "in etotal",ipot
 744       if (wtor_d.gt.0) then
 745        call etor_d(etors_d)
 746       else
 747        etors_d=0
 748       endif
 749 !      print *,"Processor",myrank," computed Utord"
 750 !
 751 ! 21/5/07 Calculate local sicdechain correlation energy
 752 !
 753       if (wsccor.gt.0.0d0) then
 754         call eback_sc_corr(esccor)
 755       else
 756         esccor=0.0d0
 757       endif
 758
 759 !      write(iout,*) "before multibody"
 760       call flush(iout)
 761 !      print *,"Processor",myrank," computed Usccorr"
 762 !
 763 ! 12/1/95 Multi-body terms
 764 !
 765       n_corr=0
 766       n_corr1=0
 767       call flush(iout)
 768       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 769           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 770          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 771 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 772 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 773       else
 774          ecorr=0.0d0
 775          ecorr5=0.0d0
 776          ecorr6=0.0d0
 777          eturn6=0.0d0
 778       endif
 779 !elwrite(iout,*) "in etotal",ipot
 780       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 781          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 782 !d         write (iout,*) "multibody_hb ecorr",ecorr
 783       endif
 784 !      write(iout,*) "afeter  multibody hb"
 785
 786 !      print *,"Processor",myrank," computed Ucorr"
 787 !
 788 ! If performing constraint dynamics, call the constraint energy
 789 !  after the equilibration time
 790       if(usampl.and.totT.gt.eq_time) then
 791 !elwrite(iout,*) "afeter  multibody hb"
 792          call EconstrQ
 793 !elwrite(iout,*) "afeter  multibody hb"
 794          call Econstr_back
 795 !elwrite(iout,*) "afeter  multibody hb"
 796       else
 797          Uconst=0.0d0
 798          Uconst_back=0.0d0
 799       endif
 800       call flush(iout)
 801 !         write(iout,*) "after Econstr"
 802
 803       if (wliptran.gt.0) then
 804 !        print *,"PRZED WYWOLANIEM"
 805         call Eliptransfer(eliptran)
 806       else
 807        eliptran=0.0d0
 808       endif
 809       if (fg_rank.eq.0) then
 810       if (AFMlog.gt.0) then
 811         call AFMforce(Eafmforce)
 812       else if (selfguide.gt.0) then
 813         call AFMvel(Eafmforce)
 814       else
 815         Eafmforce=0.0d0
 816       endif
 817       endif
 818       if (tubemode.eq.1) then
 819        call calctube(etube)
 820       else if (tubemode.eq.2) then
 821        call calctube2(etube)
 822       elseif (tubemode.eq.3) then
 823        call calcnano(etube)
 824       else
 825        etube=0.0d0
 826       endif
 827 !--------------------------------------------------------
 828 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 829 !      print *,"before",ees,evdw1,ecorr
 830 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 831       if (nres_molec(2).gt.0) then
 832       call ebond_nucl(estr_nucl)
 833       call ebend_nucl(ebe_nucl)
 834       call etor_nucl(etors_nucl)
 835       call esb_gb(evdwsb,eelsb)
 836       call epp_nucl_sub(evdwpp,eespp)
 837       call epsb(evdwpsb,eelpsb)
 838       call esb(esbloc)
 839       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 840       else
 841        etors_nucl=0.0d0
 842        estr_nucl=0.0d0
 843        ecorr3_nucl=0.0d0
 844        ecorr_nucl=0.0d0
 845        ebe_nucl=0.0d0
 846        evdwsb=0.0d0
 847        eelsb=0.0d0
 848        esbloc=0.0d0
 849        evdwpsb=0.0d0
 850        eelpsb=0.0d0
 851        evdwpp=0.0d0
 852        eespp=0.0d0
 853        etors_d_nucl=0.0d0
 854       endif
 855 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 856 !      print *,"before ecatcat",wcatcat
 857       if (nres_molec(5).gt.0) then
 858       if (nfgtasks.gt.1) then
 859       if (fg_rank.eq.0) then
 860       call ecatcat(ecationcation)
 861       endif
 862       else
 863       call ecatcat(ecationcation)
 864       endif
 865       if (oldion.gt.0) then
 866       call ecat_prot(ecation_prot)
 867       else
 868       call ecats_prot_amber(ecation_prot)
 869       endif
 870       else
 871       ecationcation=0.0d0
 872       ecation_prot=0.0d0
 873       endif
 874       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 875       call eprot_sc_base(escbase)
 876       call epep_sc_base(epepbase)
 877       call eprot_sc_phosphate(escpho)
 878       call eprot_pep_phosphate(epeppho)
 879       else
 880       epepbase=0.0
 881       escbase=0.0
 882       escpho=0.0
 883       epeppho=0.0
 884       endif
 885 !      call ecatcat(ecationcation)
 886 !      print *,"after ebend", wtor_nucl
 887 #ifdef TIMING
 888       time_enecalc=time_enecalc+MPI_Wtime()-time00
 889 #endif
 890 !      print *,"Processor",myrank," computed Uconstr"
 891 #ifdef TIMING
 892       time00=MPI_Wtime()
 893 #endif
 894 !
 895 ! Sum the energies
 896 !
 897       energia(1)=evdw
 898 #ifdef SCP14
 899       energia(2)=evdw2-evdw2_14
 900       energia(18)=evdw2_14
 901 #else
 902       energia(2)=evdw2
 903       energia(18)=0.0d0
 904 #endif
 905 #ifdef SPLITELE
 906       energia(3)=ees
 907       energia(16)=evdw1
 908 #else
 909       energia(3)=ees+evdw1
 910       energia(16)=0.0d0
 911 #endif
 912       energia(4)=ecorr
 913       energia(5)=ecorr5
 914       energia(6)=ecorr6
 915       energia(7)=eel_loc
 916       energia(8)=eello_turn3
 917       energia(9)=eello_turn4
 918       energia(10)=eturn6
 919       energia(11)=ebe
 920       energia(12)=escloc
 921       energia(13)=etors
 922       energia(14)=etors_d
 923       energia(15)=ehpb
 924       energia(19)=edihcnstr
 925       energia(17)=estr
 926       energia(20)=Uconst+Uconst_back
 927       energia(21)=esccor
 928       energia(22)=eliptran
 929       energia(23)=Eafmforce
 930       energia(24)=ethetacnstr
 931       energia(25)=etube
 932 !---------------------------------------------------------------
 933       energia(26)=evdwpp
 934       energia(27)=eespp
 935       energia(28)=evdwpsb
 936       energia(29)=eelpsb
 937       energia(30)=evdwsb
 938       energia(31)=eelsb
 939       energia(32)=estr_nucl
 940       energia(33)=ebe_nucl
 941       energia(34)=esbloc
 942       energia(35)=etors_nucl
 943       energia(36)=etors_d_nucl
 944       energia(37)=ecorr_nucl
 945       energia(38)=ecorr3_nucl
 946 !----------------------------------------------------------------------
 947 !    Here are the energies showed per procesor if the are more processors
 948 !    per molecule then we sum it up in sum_energy subroutine
 949 !      print *," Processor",myrank," calls SUM_ENERGY"
 950       energia(42)=ecation_prot
 951       energia(41)=ecationcation
 952       energia(46)=escbase
 953       energia(47)=epepbase
 954       energia(48)=escpho
 955       energia(49)=epeppho
 956 !      energia(50)=ecations_prot_amber
 957       call sum_energy(energia,.true.)
 958       if (dyn_ss) call dyn_set_nss
 959 !      print *," Processor",myrank," left SUM_ENERGY"
 960 #ifdef TIMING
 961       time_sumene=time_sumene+MPI_Wtime()-time00
 962 #endif
 963 !        call enerprint(energia)
 964 !elwrite(iout,*)"finish etotal"
 965       return
 966       end subroutine etotal
 967 !-----------------------------------------------------------------------------
 968       subroutine sum_energy(energia,reduce)
 969 !      implicit real*8 (a-h,o-z)
 970 !      include 'DIMENSIONS'
 971 #ifndef ISNAN
 972       external proc_proc
 973 #ifdef WINPGI
 974 !MS$ATTRIBUTES C ::  proc_proc
 975 #endif
 976 #endif
 977 #ifdef MPI
 978       include "mpif.h"
 979 #endif
 980 !      include 'COMMON.SETUP'
 981 !      include 'COMMON.IOUNITS'
 982       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 983 !      include 'COMMON.FFIELD'
 984 !      include 'COMMON.DERIV'
 985 !      include 'COMMON.INTERACT'
 986 !      include 'COMMON.SBRIDGE'
 987 !      include 'COMMON.CHAIN'
 988 !      include 'COMMON.VAR'
 989 !      include 'COMMON.CONTROL'
 990 !      include 'COMMON.TIME1'
 991       logical :: reduce
 992       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 993       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 994       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 995         eliptran,etube, Eafmforce,ethetacnstr
 996       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 997                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 998                       ecorr3_nucl
 999       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
1000       real(kind=8) :: escbase,epepbase,escpho,epeppho
1001       integer :: i
1002 #ifdef MPI
1003       integer :: ierr
1004       real(kind=8) :: time00
1005       if (nfgtasks.gt.1 .and. reduce) then
1006
1007 #ifdef DEBUG
1008         write (iout,*) "energies before REDUCE"
1009         call enerprint(energia)
1010         call flush(iout)
1011 #endif
1012         do i=0,n_ene
1013           enebuff(i)=energia(i)
1014         enddo
1015         time00=MPI_Wtime()
1016         call MPI_Barrier(FG_COMM,IERR)
1017         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1018         time00=MPI_Wtime()
1019         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1020           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1021 #ifdef DEBUG
1022         write (iout,*) "energies after REDUCE"
1023         call enerprint(energia)
1024         call flush(iout)
1025 #endif
1026         time_Reduce=time_Reduce+MPI_Wtime()-time00
1027       endif
1028       if (fg_rank.eq.0) then
1029 #endif
1030       evdw=energia(1)
1031 #ifdef SCP14
1032       evdw2=energia(2)+energia(18)
1033       evdw2_14=energia(18)
1034 #else
1035       evdw2=energia(2)
1036 #endif
1037 #ifdef SPLITELE
1038       ees=energia(3)
1039       evdw1=energia(16)
1040 #else
1041       ees=energia(3)
1042       evdw1=0.0d0
1043 #endif
1044       ecorr=energia(4)
1045       ecorr5=energia(5)
1046       ecorr6=energia(6)
1047       eel_loc=energia(7)
1048       eello_turn3=energia(8)
1049       eello_turn4=energia(9)
1050       eturn6=energia(10)
1051       ebe=energia(11)
1052       escloc=energia(12)
1053       etors=energia(13)
1054       etors_d=energia(14)
1055       ehpb=energia(15)
1056       edihcnstr=energia(19)
1057       estr=energia(17)
1058       Uconst=energia(20)
1059       esccor=energia(21)
1060       eliptran=energia(22)
1061       Eafmforce=energia(23)
1062       ethetacnstr=energia(24)
1063       etube=energia(25)
1064       evdwpp=energia(26)
1065       eespp=energia(27)
1066       evdwpsb=energia(28)
1067       eelpsb=energia(29)
1068       evdwsb=energia(30)
1069       eelsb=energia(31)
1070       estr_nucl=energia(32)
1071       ebe_nucl=energia(33)
1072       esbloc=energia(34)
1073       etors_nucl=energia(35)
1074       etors_d_nucl=energia(36)
1075       ecorr_nucl=energia(37)
1076       ecorr3_nucl=energia(38)
1077       ecation_prot=energia(42)
1078       ecationcation=energia(41)
1079       escbase=energia(46)
1080       epepbase=energia(47)
1081       escpho=energia(48)
1082       epeppho=energia(49)
1083 !      ecations_prot_amber=energia(50)
1084
1085 !      energia(41)=ecation_prot
1086 !      energia(42)=ecationcation
1087
1088
1089 #ifdef SPLITELE
1090       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1091        +wang*ebe+wtor*etors+wscloc*escloc &
1092        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1093        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1094        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1095        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1096        +Eafmforce+ethetacnstr  &
1097        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1098        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1099        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1100        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1101        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1102        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1103 #else
1104       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1105        +wang*ebe+wtor*etors+wscloc*escloc &
1106        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1107        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1108        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1109        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1110        +Eafmforce+ethetacnstr &
1111        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1112        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1113        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1114        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1115        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1116        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1117 #endif
1118       energia(0)=etot
1119 ! detecting NaNQ
1120 #ifdef ISNAN
1121 #ifdef AIX
1122       if (isnan(etot).ne.0) energia(0)=1.0d+99
1123 #else
1124       if (isnan(etot)) energia(0)=1.0d+99
1125 #endif
1126 #else
1127       i=0
1128 #ifdef WINPGI
1129       idumm=proc_proc(etot,i)
1130 #else
1131       call proc_proc(etot,i)
1132 #endif
1133       if(i.eq.1)energia(0)=1.0d+99
1134 #endif
1135 #ifdef MPI
1136       endif
1137 #endif
1138 !      call enerprint(energia)
1139       call flush(iout)
1140       return
1141       end subroutine sum_energy
1142 !-----------------------------------------------------------------------------
1143       subroutine rescale_weights(t_bath)
1144 !      implicit real*8 (a-h,o-z)
1145 #ifdef MPI
1146       include 'mpif.h'
1147 #endif
1148 !      include 'DIMENSIONS'
1149 !      include 'COMMON.IOUNITS'
1150 !      include 'COMMON.FFIELD'
1151 !      include 'COMMON.SBRIDGE'
1152       real(kind=8) :: kfac=2.4d0
1153       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1154 !el local variables
1155       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1156       real(kind=8) :: T0=3.0d2
1157       integer :: ierror
1158 !      facT=temp0/t_bath
1159 !      facT=2*temp0/(t_bath+temp0)
1160       if (rescale_mode.eq.0) then
1161         facT(1)=1.0d0
1162         facT(2)=1.0d0
1163         facT(3)=1.0d0
1164         facT(4)=1.0d0
1165         facT(5)=1.0d0
1166         facT(6)=1.0d0
1167       else if (rescale_mode.eq.1) then
1168         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1169         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1170         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1171         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1172         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1173 #ifdef WHAM_RUN
1174 !#if defined(WHAM_RUN) || defined(CLUSTER)
1175 #if defined(FUNCTH)
1176 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1177         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1178 #elif defined(FUNCT)
1179         facT(6)=t_bath/T0
1180 #else
1181         facT(6)=1.0d0
1182 #endif
1183 #endif
1184       else if (rescale_mode.eq.2) then
1185         x=t_bath/temp0
1186         x2=x*x
1187         x3=x2*x
1188         x4=x3*x
1189         x5=x4*x
1190         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1191         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1192         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1193         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1194         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1195 #ifdef WHAM_RUN
1196 !#if defined(WHAM_RUN) || defined(CLUSTER)
1197 #if defined(FUNCTH)
1198         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1199 #elif defined(FUNCT)
1200         facT(6)=t_bath/T0
1201 #else
1202         facT(6)=1.0d0
1203 #endif
1204 #endif
1205       else
1206         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1207         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1208 #ifdef MPI
1209        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1210 #endif
1211        stop 555
1212       endif
1213       welec=weights(3)*fact(1)
1214       wcorr=weights(4)*fact(3)
1215       wcorr5=weights(5)*fact(4)
1216       wcorr6=weights(6)*fact(5)
1217       wel_loc=weights(7)*fact(2)
1218       wturn3=weights(8)*fact(2)
1219       wturn4=weights(9)*fact(3)
1220       wturn6=weights(10)*fact(5)
1221       wtor=weights(13)*fact(1)
1222       wtor_d=weights(14)*fact(2)
1223       wsccor=weights(21)*fact(1)
1224       welpsb=weights(28)*fact(1)
1225       wcorr_nucl= weights(37)*fact(1)
1226       wcorr3_nucl=weights(38)*fact(2)
1227       wtor_nucl=  weights(35)*fact(1)
1228       wtor_d_nucl=weights(36)*fact(2)
1229       wpepbase=weights(47)*fact(1)
1230       return
1231       end subroutine rescale_weights
1232 !-----------------------------------------------------------------------------
1233       subroutine enerprint(energia)
1234 !      implicit real*8 (a-h,o-z)
1235 !      include 'DIMENSIONS'
1236 !      include 'COMMON.IOUNITS'
1237 !      include 'COMMON.FFIELD'
1238 !      include 'COMMON.SBRIDGE'
1239 !      include 'COMMON.MD'
1240       real(kind=8) :: energia(0:n_ene)
1241 !el local variables
1242       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1243       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1244       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1245        etube,ethetacnstr,Eafmforce
1246       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1247                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1248                       ecorr3_nucl
1249       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
1250       real(kind=8) :: escbase,epepbase,escpho,epeppho
1251
1252       etot=energia(0)
1253       evdw=energia(1)
1254       evdw2=energia(2)
1255 #ifdef SCP14
1256       evdw2=energia(2)+energia(18)
1257 #else
1258       evdw2=energia(2)
1259 #endif
1260       ees=energia(3)
1261 #ifdef SPLITELE
1262       evdw1=energia(16)
1263 #endif
1264       ecorr=energia(4)
1265       ecorr5=energia(5)
1266       ecorr6=energia(6)
1267       eel_loc=energia(7)
1268       eello_turn3=energia(8)
1269       eello_turn4=energia(9)
1270       eello_turn6=energia(10)
1271       ebe=energia(11)
1272       escloc=energia(12)
1273       etors=energia(13)
1274       etors_d=energia(14)
1275       ehpb=energia(15)
1276       edihcnstr=energia(19)
1277       estr=energia(17)
1278       Uconst=energia(20)
1279       esccor=energia(21)
1280       eliptran=energia(22)
1281       Eafmforce=energia(23)
1282       ethetacnstr=energia(24)
1283       etube=energia(25)
1284       evdwpp=energia(26)
1285       eespp=energia(27)
1286       evdwpsb=energia(28)
1287       eelpsb=energia(29)
1288       evdwsb=energia(30)
1289       eelsb=energia(31)
1290       estr_nucl=energia(32)
1291       ebe_nucl=energia(33)
1292       esbloc=energia(34)
1293       etors_nucl=energia(35)
1294       etors_d_nucl=energia(36)
1295       ecorr_nucl=energia(37)
1296       ecorr3_nucl=energia(38)
1297       ecation_prot=energia(42)
1298       ecationcation=energia(41)
1299       escbase=energia(46)
1300       epepbase=energia(47)
1301       escpho=energia(48)
1302       epeppho=energia(49)
1303 !      ecations_prot_amber=energia(50)
1304 #ifdef SPLITELE
1305       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1306         estr,wbond,ebe,wang,&
1307         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1308         ecorr,wcorr,&
1309         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1310         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1311         edihcnstr,ethetacnstr,ebr*nss,&
1312         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1313         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1314         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1315         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1316         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1317         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1318         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1319         etot
1320    10 format (/'Virtual-chain energies:'// &
1321        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1322        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1323        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1324        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1325        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1326        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1327        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1328        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1329        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1330        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1331        ' (SS bridges & dist. cnstr.)'/ &
1332        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1333        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1334        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1335        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1336        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1337        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1338        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1339        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1340        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1341        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1342        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1343        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1344        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1345        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1346        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1347        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1348        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1349        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1350        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1351        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1352        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1353        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1354        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1355        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1356        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1357        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1358        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1359        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1360        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1361        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1362        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1363        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1364        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1365        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1366        'ETOT=  ',1pE16.6,' (total)')
1367 #else
1368       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1369         estr,wbond,ebe,wang,&
1370         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1371         ecorr,wcorr,&
1372         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1373         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1374         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1375         etube,wtube, &
1376         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1377         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1378         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1379         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1380         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1381         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1382         etot
1383    10 format (/'Virtual-chain energies:'// &
1384        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1385        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1386        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1387        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1388        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1389        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1390        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1391        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1392        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1393        ' (SS bridges & dist. cnstr.)'/ &
1394        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1395        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1396        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1397        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1398        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1399        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1400        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1401        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1402        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1403        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1404        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1405        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1406        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1407        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1408        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1409        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1410        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1411        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1412        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1413        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1414        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1415        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1416        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1417        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1418        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1419        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1420        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1421        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1422        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1423        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1424        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1425        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1426        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1427        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1428        'ETOT=  ',1pE16.6,' (total)')
1429 #endif
1430       return
1431       end subroutine enerprint
1432 !-----------------------------------------------------------------------------
1433       subroutine elj(evdw)
1434 !
1435 ! This subroutine calculates the interaction energy of nonbonded side chains
1436 ! assuming the LJ potential of interaction.
1437 !
1438 !      implicit real*8 (a-h,o-z)
1439 !      include 'DIMENSIONS'
1440       real(kind=8),parameter :: accur=1.0d-10
1441 !      include 'COMMON.GEO'
1442 !      include 'COMMON.VAR'
1443 !      include 'COMMON.LOCAL'
1444 !      include 'COMMON.CHAIN'
1445 !      include 'COMMON.DERIV'
1446 !      include 'COMMON.INTERACT'
1447 !      include 'COMMON.TORSION'
1448 !      include 'COMMON.SBRIDGE'
1449 !      include 'COMMON.NAMES'
1450 !      include 'COMMON.IOUNITS'
1451 !      include 'COMMON.CONTACTS'
1452       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1453       integer :: num_conti
1454 !el local variables
1455       integer :: i,itypi,iint,j,itypi1,itypj,k
1456       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1457        aa,bb,sslipj,ssgradlipj
1458       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1459       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1460
1461 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1462       evdw=0.0D0
1463 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1464 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1465 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1466 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1467
1468       do i=iatsc_s,iatsc_e
1469         itypi=iabs(itype(i,1))
1470         if (itypi.eq.ntyp1) cycle
1471         itypi1=iabs(itype(i+1,1))
1472         xi=c(1,nres+i)
1473         yi=c(2,nres+i)
1474         zi=c(3,nres+i)
1475         call to_box(xi,yi,zi)
1476         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1477
1478 ! Change 12/1/95
1479         num_conti=0
1480 !
1481 ! Calculate SC interaction energy.
1482 !
1483         do iint=1,nint_gr(i)
1484 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1485 !d   &                  'iend=',iend(i,iint)
1486           do j=istart(i,iint),iend(i,iint)
1487             itypj=iabs(itype(j,1))
1488             if (itypj.eq.ntyp1) cycle
1489             xj=c(1,nres+j)-xi
1490             yj=c(2,nres+j)-yi
1491             zj=c(3,nres+j)-zi
1492             call to_box(xj,yj,zj)
1493             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1494             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1495              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1496             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1497              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1498             xj=boxshift(xj-xi,boxxsize)
1499             yj=boxshift(yj-yi,boxysize)
1500             zj=boxshift(zj-zi,boxzsize)
1501 ! Change 12/1/95 to calculate four-body interactions
1502             rij=xj*xj+yj*yj+zj*zj
1503             rrij=1.0D0/rij
1504 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1505             eps0ij=eps(itypi,itypj)
1506             fac=rrij**expon2
1507             e1=fac*fac*aa_aq(itypi,itypj)
1508             e2=fac*bb_aq(itypi,itypj)
1509             evdwij=e1+e2
1510 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1511 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1512 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1513 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1514 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1515 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1516             evdw=evdw+evdwij
1517 !
1518 ! Calculate the components of the gradient in DC and X
1519 !
1520             fac=-rrij*(e1+evdwij)
1521             gg(1)=xj*fac
1522             gg(2)=yj*fac
1523             gg(3)=zj*fac
1524             do k=1,3
1525               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1526               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1527               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1528               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1529             enddo
1530 !grad            do k=i,j-1
1531 !grad              do l=1,3
1532 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1533 !grad              enddo
1534 !grad            enddo
1535 !
1536 ! 12/1/95, revised on 5/20/97
1537 !
1538 ! Calculate the contact function. The ith column of the array JCONT will
1539 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1540 ! greater than I). The arrays FACONT and GACONT will contain the values of
1541 ! the contact function and its derivative.
1542 !
1543 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1544 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1545 ! Uncomment next line, if the correlation interactions are contact function only
1546             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1547               rij=dsqrt(rij)
1548               sigij=sigma(itypi,itypj)
1549               r0ij=rs0(itypi,itypj)
1550 !
1551 ! Check whether the SC's are not too far to make a contact.
1552 !
1553               rcut=1.5d0*r0ij
1554               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1555 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1556 !
1557               if (fcont.gt.0.0D0) then
1558 ! If the SC-SC distance if close to sigma, apply spline.
1559 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1560 !Adam &             fcont1,fprimcont1)
1561 !Adam           fcont1=1.0d0-fcont1
1562 !Adam           if (fcont1.gt.0.0d0) then
1563 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1564 !Adam             fcont=fcont*fcont1
1565 !Adam           endif
1566 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1567 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1568 !ga             do k=1,3
1569 !ga               gg(k)=gg(k)*eps0ij
1570 !ga             enddo
1571 !ga             eps0ij=-evdwij*eps0ij
1572 ! Uncomment for AL's type of SC correlation interactions.
1573 !adam           eps0ij=-evdwij
1574                 num_conti=num_conti+1
1575                 jcont(num_conti,i)=j
1576                 facont(num_conti,i)=fcont*eps0ij
1577                 fprimcont=eps0ij*fprimcont/rij
1578                 fcont=expon*fcont
1579 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1580 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1581 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1582 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1583                 gacont(1,num_conti,i)=-fprimcont*xj
1584                 gacont(2,num_conti,i)=-fprimcont*yj
1585                 gacont(3,num_conti,i)=-fprimcont*zj
1586 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1587 !d              write (iout,'(2i3,3f10.5)')
1588 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1589               endif
1590             endif
1591           enddo      ! j
1592         enddo        ! iint
1593 ! Change 12/1/95
1594         num_cont(i)=num_conti
1595       enddo          ! i
1596       do i=1,nct
1597         do j=1,3
1598           gvdwc(j,i)=expon*gvdwc(j,i)
1599           gvdwx(j,i)=expon*gvdwx(j,i)
1600         enddo
1601       enddo
1602 !******************************************************************************
1603 !
1604 !                              N O T E !!!
1605 !
1606 ! To save time, the factor of EXPON has been extracted from ALL components
1607 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1608 ! use!
1609 !
1610 !******************************************************************************
1611       return
1612       end subroutine elj
1613 !-----------------------------------------------------------------------------
1614       subroutine eljk(evdw)
1615 !
1616 ! This subroutine calculates the interaction energy of nonbonded side chains
1617 ! assuming the LJK potential of interaction.
1618 !
1619 !      implicit real*8 (a-h,o-z)
1620 !      include 'DIMENSIONS'
1621 !      include 'COMMON.GEO'
1622 !      include 'COMMON.VAR'
1623 !      include 'COMMON.LOCAL'
1624 !      include 'COMMON.CHAIN'
1625 !      include 'COMMON.DERIV'
1626 !      include 'COMMON.INTERACT'
1627 !      include 'COMMON.IOUNITS'
1628 !      include 'COMMON.NAMES'
1629       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1630       logical :: scheck
1631 !el local variables
1632       integer :: i,iint,j,itypi,itypi1,k,itypj
1633       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1634          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1635       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1636
1637 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1638       evdw=0.0D0
1639       do i=iatsc_s,iatsc_e
1640         itypi=iabs(itype(i,1))
1641         if (itypi.eq.ntyp1) cycle
1642         itypi1=iabs(itype(i+1,1))
1643         xi=c(1,nres+i)
1644         yi=c(2,nres+i)
1645         zi=c(3,nres+i)
1646         call to_box(xi,yi,zi)
1647         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1648
1649 !
1650 ! Calculate SC interaction energy.
1651 !
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654             itypj=iabs(itype(j,1))
1655             if (itypj.eq.ntyp1) cycle
1656             xj=c(1,nres+j)-xi
1657             yj=c(2,nres+j)-yi
1658             zj=c(3,nres+j)-zi
1659             call to_box(xj,yj,zj)
1660             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1661             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1662              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1663             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1664              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1665             xj=boxshift(xj-xi,boxxsize)
1666             yj=boxshift(yj-yi,boxysize)
1667             zj=boxshift(zj-zi,boxzsize)
1668             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1669             fac_augm=rrij**expon
1670             e_augm=augm(itypi,itypj)*fac_augm
1671             r_inv_ij=dsqrt(rrij)
1672             rij=1.0D0/r_inv_ij
1673             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1674             fac=r_shift_inv**expon
1675             e1=fac*fac*aa_aq(itypi,itypj)
1676             e2=fac*bb_aq(itypi,itypj)
1677             evdwij=e_augm+e1+e2
1678 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1679 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1680 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1681 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1682 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1683 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1684 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1685             evdw=evdw+evdwij
1686 !
1687 ! Calculate the components of the gradient in DC and X
1688 !
1689             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1690             gg(1)=xj*fac
1691             gg(2)=yj*fac
1692             gg(3)=zj*fac
1693             do k=1,3
1694               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1695               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1696               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1697               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1698             enddo
1699 !grad            do k=i,j-1
1700 !grad              do l=1,3
1701 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1702 !grad              enddo
1703 !grad            enddo
1704           enddo      ! j
1705         enddo        ! iint
1706       enddo          ! i
1707       do i=1,nct
1708         do j=1,3
1709           gvdwc(j,i)=expon*gvdwc(j,i)
1710           gvdwx(j,i)=expon*gvdwx(j,i)
1711         enddo
1712       enddo
1713       return
1714       end subroutine eljk
1715 !-----------------------------------------------------------------------------
1716       subroutine ebp(evdw)
1717 !
1718 ! This subroutine calculates the interaction energy of nonbonded side chains
1719 ! assuming the Berne-Pechukas potential of interaction.
1720 !
1721       use comm_srutu
1722       use calc_data
1723 !      implicit real*8 (a-h,o-z)
1724 !      include 'DIMENSIONS'
1725 !      include 'COMMON.GEO'
1726 !      include 'COMMON.VAR'
1727 !      include 'COMMON.LOCAL'
1728 !      include 'COMMON.CHAIN'
1729 !      include 'COMMON.DERIV'
1730 !      include 'COMMON.NAMES'
1731 !      include 'COMMON.INTERACT'
1732 !      include 'COMMON.IOUNITS'
1733 !      include 'COMMON.CALC'
1734       use comm_srutu
1735 !el      integer :: icall
1736 !el      common /srutu/ icall
1737 !     double precision rrsave(maxdim)
1738       logical :: lprn
1739 !el local variables
1740       integer :: iint,itypi,itypi1,itypj
1741       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1742         ssgradlipj, aa, bb
1743       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1744
1745 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1746       evdw=0.0D0
1747 !     if (icall.eq.0) then
1748 !       lprn=.true.
1749 !     else
1750         lprn=.false.
1751 !     endif
1752 !el      ind=0
1753       do i=iatsc_s,iatsc_e
1754         itypi=iabs(itype(i,1))
1755         if (itypi.eq.ntyp1) cycle
1756         itypi1=iabs(itype(i+1,1))
1757         xi=c(1,nres+i)
1758         yi=c(2,nres+i)
1759         zi=c(3,nres+i)
1760         call to_box(xi,yi,zi)
1761         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1762         dxi=dc_norm(1,nres+i)
1763         dyi=dc_norm(2,nres+i)
1764         dzi=dc_norm(3,nres+i)
1765 !        dsci_inv=dsc_inv(itypi)
1766         dsci_inv=vbld_inv(i+nres)
1767 !
1768 ! Calculate SC interaction energy.
1769 !
1770         do iint=1,nint_gr(i)
1771           do j=istart(i,iint),iend(i,iint)
1772 !el            ind=ind+1
1773             itypj=iabs(itype(j,1))
1774             if (itypj.eq.ntyp1) cycle
1775 !            dscj_inv=dsc_inv(itypj)
1776             dscj_inv=vbld_inv(j+nres)
1777             chi1=chi(itypi,itypj)
1778             chi2=chi(itypj,itypi)
1779             chi12=chi1*chi2
1780             chip1=chip(itypi)
1781             chip2=chip(itypj)
1782             chip12=chip1*chip2
1783             alf1=alp(itypi)
1784             alf2=alp(itypj)
1785             alf12=0.5D0*(alf1+alf2)
1786 ! For diagnostics only!!!
1787 !           chi1=0.0D0
1788 !           chi2=0.0D0
1789 !           chi12=0.0D0
1790 !           chip1=0.0D0
1791 !           chip2=0.0D0
1792 !           chip12=0.0D0
1793 !           alf1=0.0D0
1794 !           alf2=0.0D0
1795 !           alf12=0.0D0
1796             xj=c(1,nres+j)-xi
1797             yj=c(2,nres+j)-yi
1798             zj=c(3,nres+j)-zi
1799             call to_box(xj,yj,zj)
1800             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1801             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1802              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1803             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1804              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1805             xj=boxshift(xj-xi,boxxsize)
1806             yj=boxshift(yj-yi,boxysize)
1807             zj=boxshift(zj-zi,boxzsize)
1808             dxj=dc_norm(1,nres+j)
1809             dyj=dc_norm(2,nres+j)
1810             dzj=dc_norm(3,nres+j)
1811             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1812 !d          if (icall.eq.0) then
1813 !d            rrsave(ind)=rrij
1814 !d          else
1815 !d            rrij=rrsave(ind)
1816 !d          endif
1817             rij=dsqrt(rrij)
1818 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1819             call sc_angular
1820 ! Calculate whole angle-dependent part of epsilon and contributions
1821 ! to its derivatives
1822             fac=(rrij*sigsq)**expon2
1823             e1=fac*fac*aa_aq(itypi,itypj)
1824             e2=fac*bb_aq(itypi,itypj)
1825             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1826             eps2der=evdwij*eps3rt
1827             eps3der=evdwij*eps2rt
1828             evdwij=evdwij*eps2rt*eps3rt
1829             evdw=evdw+evdwij
1830             if (lprn) then
1831             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1832             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1833 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1834 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1835 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1836 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1837 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1838 !d     &        evdwij
1839             endif
1840 ! Calculate gradient components.
1841             e1=e1*eps1*eps2rt**2*eps3rt**2
1842             fac=-expon*(e1+evdwij)
1843             sigder=fac/sigsq
1844             fac=rrij*fac
1845 ! Calculate radial part of the gradient
1846             gg(1)=xj*fac
1847             gg(2)=yj*fac
1848             gg(3)=zj*fac
1849 ! Calculate the angular part of the gradient and sum add the contributions
1850 ! to the appropriate components of the Cartesian gradient.
1851             call sc_grad
1852           enddo      ! j
1853         enddo        ! iint
1854       enddo          ! i
1855 !     stop
1856       return
1857       end subroutine ebp
1858 !-----------------------------------------------------------------------------
1859       subroutine egb(evdw)
1860 !
1861 ! This subroutine calculates the interaction energy of nonbonded side chains
1862 ! assuming the Gay-Berne potential of interaction.
1863 !
1864       use calc_data
1865 !      implicit real*8 (a-h,o-z)
1866 !      include 'DIMENSIONS'
1867 !      include 'COMMON.GEO'
1868 !      include 'COMMON.VAR'
1869 !      include 'COMMON.LOCAL'
1870 !      include 'COMMON.CHAIN'
1871 !      include 'COMMON.DERIV'
1872 !      include 'COMMON.NAMES'
1873 !      include 'COMMON.INTERACT'
1874 !      include 'COMMON.IOUNITS'
1875 !      include 'COMMON.CALC'
1876 !      include 'COMMON.CONTROL'
1877 !      include 'COMMON.SBRIDGE'
1878       logical :: lprn
1879 !el local variables
1880       integer :: iint,itypi,itypi1,itypj,subchap,icont
1881       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1882       real(kind=8) :: evdw,sig0ij
1883       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1884                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1885                     sslipi,sslipj,faclip
1886       integer :: ii
1887       real(kind=8) :: fracinbuf
1888
1889 !cccc      energy_dec=.false.
1890 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1891       evdw=0.0D0
1892       lprn=.false.
1893 !     if (icall.eq.0) lprn=.false.
1894 !el      ind=0
1895       dCAVdOM2=0.0d0
1896       dGCLdOM2=0.0d0
1897       dPOLdOM2=0.0d0
1898       dCAVdOM1=0.0d0
1899       dGCLdOM1=0.0d0
1900       dPOLdOM1=0.0d0
1901
1902
1903       do icont=g_listscsc_start,g_listscsc_end
1904       i=newcontlisti(icont)
1905       j=newcontlistj(icont)
1906
1907 !      do i=iatsc_s,iatsc_e
1908 !C        print *,"I am in EVDW",i
1909         itypi=iabs(itype(i,1))
1910 !        if (i.ne.47) cycle
1911         if (itypi.eq.ntyp1) cycle
1912         itypi1=iabs(itype(i+1,1))
1913         xi=c(1,nres+i)
1914         yi=c(2,nres+i)
1915         zi=c(3,nres+i)
1916         call to_box(xi,yi,zi)
1917         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1918
1919         dxi=dc_norm(1,nres+i)
1920         dyi=dc_norm(2,nres+i)
1921         dzi=dc_norm(3,nres+i)
1922 !        dsci_inv=dsc_inv(itypi)
1923         dsci_inv=vbld_inv(i+nres)
1924 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1925 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1926 !
1927 ! Calculate SC interaction energy.
1928 !
1929 !        do iint=1,nint_gr(i)
1930 !          do j=istart(i,iint),iend(i,iint)
1931             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1932               call dyn_ssbond_ene(i,j,evdwij)
1933               evdw=evdw+evdwij
1934               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1935                               'evdw',i,j,evdwij,' ss'
1936 !              if (energy_dec) write (iout,*) &
1937 !                              'evdw',i,j,evdwij,' ss'
1938              do k=j+1,iend(i,iint)
1939 !C search over all next residues
1940               if (dyn_ss_mask(k)) then
1941 !C check if they are cysteins
1942 !C              write(iout,*) 'k=',k
1943
1944 !c              write(iout,*) "PRZED TRI", evdwij
1945 !               evdwij_przed_tri=evdwij
1946               call triple_ssbond_ene(i,j,k,evdwij)
1947 !c               if(evdwij_przed_tri.ne.evdwij) then
1948 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1949 !c               endif
1950
1951 !c              write(iout,*) "PO TRI", evdwij
1952 !C call the energy function that removes the artifical triple disulfide
1953 !C bond the soubroutine is located in ssMD.F
1954               evdw=evdw+evdwij
1955               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1956                             'evdw',i,j,evdwij,'tss'
1957               endif!dyn_ss_mask(k)
1958              enddo! k
1959             ELSE
1960 !el            ind=ind+1
1961             itypj=iabs(itype(j,1))
1962             if (itypj.eq.ntyp1) cycle
1963 !             if (j.ne.78) cycle
1964 !            dscj_inv=dsc_inv(itypj)
1965             dscj_inv=vbld_inv(j+nres)
1966 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1967 !              1.0d0/vbld(j+nres) !d
1968 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1969             sig0ij=sigma(itypi,itypj)
1970             chi1=chi(itypi,itypj)
1971             chi2=chi(itypj,itypi)
1972             chi12=chi1*chi2
1973             chip1=chip(itypi)
1974             chip2=chip(itypj)
1975             chip12=chip1*chip2
1976             alf1=alp(itypi)
1977             alf2=alp(itypj)
1978             alf12=0.5D0*(alf1+alf2)
1979 ! For diagnostics only!!!
1980 !           chi1=0.0D0
1981 !           chi2=0.0D0
1982 !           chi12=0.0D0
1983 !           chip1=0.0D0
1984 !           chip2=0.0D0
1985 !           chip12=0.0D0
1986 !           alf1=0.0D0
1987 !           alf2=0.0D0
1988 !           alf12=0.0D0
1989            xj=c(1,nres+j)
1990            yj=c(2,nres+j)
1991            zj=c(3,nres+j)
1992               call to_box(xj,yj,zj)
1993               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1994               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1995                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1996               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1997                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1998               xj=boxshift(xj-xi,boxxsize)
1999               yj=boxshift(yj-yi,boxysize)
2000               zj=boxshift(zj-zi,boxzsize)
2001             dxj=dc_norm(1,nres+j)
2002             dyj=dc_norm(2,nres+j)
2003             dzj=dc_norm(3,nres+j)
2004 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2005 !            write (iout,*) "j",j," dc_norm",& !d
2006 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2007 !          write(iout,*)"rrij ",rrij
2008 !          write(iout,*)"xj yj zj ", xj, yj, zj
2009 !          write(iout,*)"xi yi zi ", xi, yi, zi
2010 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2011             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2012             rij=dsqrt(rrij)
2013             sss_ele_cut=sscale_ele(1.0d0/(rij))
2014             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2015 !            print *,sss_ele_cut,sss_ele_grad,&
2016 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2017             if (sss_ele_cut.le.0.0) cycle
2018 ! Calculate angle-dependent terms of energy and contributions to their
2019 ! derivatives.
2020             call sc_angular
2021             sigsq=1.0D0/sigsq
2022             sig=sig0ij*dsqrt(sigsq)
2023             rij_shift=1.0D0/rij-sig+sig0ij
2024 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2025 !            "sig0ij",sig0ij
2026 ! for diagnostics; uncomment
2027 !            rij_shift=1.2*sig0ij
2028 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2029             if (rij_shift.le.0.0D0) then
2030               evdw=1.0D20
2031 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2032 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2033 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2034               return
2035             endif
2036             sigder=-sig*sigsq
2037 !---------------------------------------------------------------
2038             rij_shift=1.0D0/rij_shift
2039             fac=rij_shift**expon
2040             faclip=fac
2041             e1=fac*fac*aa!(itypi,itypj)
2042             e2=fac*bb!(itypi,itypj)
2043             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2044             eps2der=evdwij*eps3rt
2045             eps3der=evdwij*eps2rt
2046 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2047 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2048 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2049             evdwij=evdwij*eps2rt*eps3rt
2050             evdw=evdw+evdwij*sss_ele_cut
2051             if (lprn) then
2052             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2053             epsi=bb**2/aa!(itypi,itypj)
2054             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2055               restyp(itypi,1),i,restyp(itypj,1),j, &
2056               epsi,sigm,chi1,chi2,chip1,chip2, &
2057               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2058               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2059               evdwij
2060             endif
2061
2062             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2063                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2064 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2065 !            if (energy_dec) write (iout,*) &
2066 !                             'evdw',i,j,evdwij
2067 !                       print *,"ZALAMKA", evdw
2068
2069 ! Calculate gradient components.
2070             e1=e1*eps1*eps2rt**2*eps3rt**2
2071             fac=-expon*(e1+evdwij)*rij_shift
2072             sigder=fac*sigder
2073             fac=rij*fac
2074 !            print *,'before fac',fac,rij,evdwij
2075             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2076             *rij
2077 !            print *,'grad part scale',fac,   &
2078 !             evdwij*sss_ele_grad/sss_ele_cut &
2079 !            /sigma(itypi,itypj)*rij
2080 !            fac=0.0d0
2081 ! Calculate the radial part of the gradient
2082             gg(1)=xj*fac
2083             gg(2)=yj*fac
2084             gg(3)=zj*fac
2085 !C Calculate the radial part of the gradient
2086             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2087        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2088         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2089        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2090             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2091             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2092
2093 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2094 ! Calculate angular part of the gradient.
2095             call sc_grad
2096             ENDIF    ! dyn_ss
2097 !          enddo      ! j
2098 !        enddo        ! iint
2099       enddo          ! i
2100 !       print *,"ZALAMKA", evdw
2101 !      write (iout,*) "Number of loop steps in EGB:",ind
2102 !ccc      energy_dec=.false.
2103       return
2104       end subroutine egb
2105 !-----------------------------------------------------------------------------
2106       subroutine egbv(evdw)
2107 !
2108 ! This subroutine calculates the interaction energy of nonbonded side chains
2109 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2110 !
2111       use comm_srutu
2112       use calc_data
2113 !      implicit real*8 (a-h,o-z)
2114 !      include 'DIMENSIONS'
2115 !      include 'COMMON.GEO'
2116 !      include 'COMMON.VAR'
2117 !      include 'COMMON.LOCAL'
2118 !      include 'COMMON.CHAIN'
2119 !      include 'COMMON.DERIV'
2120 !      include 'COMMON.NAMES'
2121 !      include 'COMMON.INTERACT'
2122 !      include 'COMMON.IOUNITS'
2123 !      include 'COMMON.CALC'
2124       use comm_srutu
2125 !el      integer :: icall
2126 !el      common /srutu/ icall
2127       logical :: lprn
2128 !el local variables
2129       integer :: iint,itypi,itypi1,itypj
2130       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2131          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2132       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2133
2134 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2135       evdw=0.0D0
2136       lprn=.false.
2137 !     if (icall.eq.0) lprn=.true.
2138 !el      ind=0
2139       do i=iatsc_s,iatsc_e
2140         itypi=iabs(itype(i,1))
2141         if (itypi.eq.ntyp1) cycle
2142         itypi1=iabs(itype(i+1,1))
2143         xi=c(1,nres+i)
2144         yi=c(2,nres+i)
2145         zi=c(3,nres+i)
2146         call to_box(xi,yi,zi)
2147         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2148         dxi=dc_norm(1,nres+i)
2149         dyi=dc_norm(2,nres+i)
2150         dzi=dc_norm(3,nres+i)
2151 !        dsci_inv=dsc_inv(itypi)
2152         dsci_inv=vbld_inv(i+nres)
2153 !
2154 ! Calculate SC interaction energy.
2155 !
2156         do iint=1,nint_gr(i)
2157           do j=istart(i,iint),iend(i,iint)
2158 !el            ind=ind+1
2159             itypj=iabs(itype(j,1))
2160             if (itypj.eq.ntyp1) cycle
2161 !            dscj_inv=dsc_inv(itypj)
2162             dscj_inv=vbld_inv(j+nres)
2163             sig0ij=sigma(itypi,itypj)
2164             r0ij=r0(itypi,itypj)
2165             chi1=chi(itypi,itypj)
2166             chi2=chi(itypj,itypi)
2167             chi12=chi1*chi2
2168             chip1=chip(itypi)
2169             chip2=chip(itypj)
2170             chip12=chip1*chip2
2171             alf1=alp(itypi)
2172             alf2=alp(itypj)
2173             alf12=0.5D0*(alf1+alf2)
2174 ! For diagnostics only!!!
2175 !           chi1=0.0D0
2176 !           chi2=0.0D0
2177 !           chi12=0.0D0
2178 !           chip1=0.0D0
2179 !           chip2=0.0D0
2180 !           chip12=0.0D0
2181 !           alf1=0.0D0
2182 !           alf2=0.0D0
2183 !           alf12=0.0D0
2184             xj=c(1,nres+j)-xi
2185             yj=c(2,nres+j)-yi
2186             zj=c(3,nres+j)-zi
2187            call to_box(xj,yj,zj)
2188            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2189            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2190             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2191            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2192             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2193            xj=boxshift(xj-xi,boxxsize)
2194            yj=boxshift(yj-yi,boxysize)
2195            zj=boxshift(zj-zi,boxzsize)
2196             dxj=dc_norm(1,nres+j)
2197             dyj=dc_norm(2,nres+j)
2198             dzj=dc_norm(3,nres+j)
2199             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2200             rij=dsqrt(rrij)
2201 ! Calculate angle-dependent terms of energy and contributions to their
2202 ! derivatives.
2203             call sc_angular
2204             sigsq=1.0D0/sigsq
2205             sig=sig0ij*dsqrt(sigsq)
2206             rij_shift=1.0D0/rij-sig+r0ij
2207 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2208             if (rij_shift.le.0.0D0) then
2209               evdw=1.0D20
2210               return
2211             endif
2212             sigder=-sig*sigsq
2213 !---------------------------------------------------------------
2214             rij_shift=1.0D0/rij_shift
2215             fac=rij_shift**expon
2216             e1=fac*fac*aa_aq(itypi,itypj)
2217             e2=fac*bb_aq(itypi,itypj)
2218             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2219             eps2der=evdwij*eps3rt
2220             eps3der=evdwij*eps2rt
2221             fac_augm=rrij**expon
2222             e_augm=augm(itypi,itypj)*fac_augm
2223             evdwij=evdwij*eps2rt*eps3rt
2224             evdw=evdw+evdwij+e_augm
2225             if (lprn) then
2226             sigm=dabs(aa_aq(itypi,itypj)/&
2227             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2228             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2229             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2230               restyp(itypi,1),i,restyp(itypj,1),j,&
2231               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2232               chi1,chi2,chip1,chip2,&
2233               eps1,eps2rt**2,eps3rt**2,&
2234               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2235               evdwij+e_augm
2236             endif
2237 ! Calculate gradient components.
2238             e1=e1*eps1*eps2rt**2*eps3rt**2
2239             fac=-expon*(e1+evdwij)*rij_shift
2240             sigder=fac*sigder
2241             fac=rij*fac-2*expon*rrij*e_augm
2242 ! Calculate the radial part of the gradient
2243             gg(1)=xj*fac
2244             gg(2)=yj*fac
2245             gg(3)=zj*fac
2246 ! Calculate angular part of the gradient.
2247             call sc_grad
2248           enddo      ! j
2249         enddo        ! iint
2250       enddo          ! i
2251       end subroutine egbv
2252 !-----------------------------------------------------------------------------
2253 !el      subroutine sc_angular in module geometry
2254 !-----------------------------------------------------------------------------
2255       subroutine e_softsphere(evdw)
2256 !
2257 ! This subroutine calculates the interaction energy of nonbonded side chains
2258 ! assuming the LJ potential of interaction.
2259 !
2260 !      implicit real*8 (a-h,o-z)
2261 !      include 'DIMENSIONS'
2262       real(kind=8),parameter :: accur=1.0d-10
2263 !      include 'COMMON.GEO'
2264 !      include 'COMMON.VAR'
2265 !      include 'COMMON.LOCAL'
2266 !      include 'COMMON.CHAIN'
2267 !      include 'COMMON.DERIV'
2268 !      include 'COMMON.INTERACT'
2269 !      include 'COMMON.TORSION'
2270 !      include 'COMMON.SBRIDGE'
2271 !      include 'COMMON.NAMES'
2272 !      include 'COMMON.IOUNITS'
2273 !      include 'COMMON.CONTACTS'
2274       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2275 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2276 !el local variables
2277       integer :: i,iint,j,itypi,itypi1,itypj,k
2278       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2279       real(kind=8) :: fac
2280
2281       evdw=0.0D0
2282       do i=iatsc_s,iatsc_e
2283         itypi=iabs(itype(i,1))
2284         if (itypi.eq.ntyp1) cycle
2285         itypi1=iabs(itype(i+1,1))
2286         xi=c(1,nres+i)
2287         yi=c(2,nres+i)
2288         zi=c(3,nres+i)
2289         call to_box(xi,yi,zi)
2290
2291 !
2292 ! Calculate SC interaction energy.
2293 !
2294         do iint=1,nint_gr(i)
2295 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2296 !d   &                  'iend=',iend(i,iint)
2297           do j=istart(i,iint),iend(i,iint)
2298             itypj=iabs(itype(j,1))
2299             if (itypj.eq.ntyp1) cycle
2300             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2301             yj=boxshift(c(2,nres+j)-yi,boxysize)
2302             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2303             rij=xj*xj+yj*yj+zj*zj
2304 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2305             r0ij=r0(itypi,itypj)
2306             r0ijsq=r0ij*r0ij
2307 !            print *,i,j,r0ij,dsqrt(rij)
2308             if (rij.lt.r0ijsq) then
2309               evdwij=0.25d0*(rij-r0ijsq)**2
2310               fac=rij-r0ijsq
2311             else
2312               evdwij=0.0d0
2313               fac=0.0d0
2314             endif
2315             evdw=evdw+evdwij
2316 !
2317 ! Calculate the components of the gradient in DC and X
2318 !
2319             gg(1)=xj*fac
2320             gg(2)=yj*fac
2321             gg(3)=zj*fac
2322             do k=1,3
2323               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2324               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2325               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2326               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2327             enddo
2328 !grad            do k=i,j-1
2329 !grad              do l=1,3
2330 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2331 !grad              enddo
2332 !grad            enddo
2333           enddo ! j
2334         enddo ! iint
2335       enddo ! i
2336       return
2337       end subroutine e_softsphere
2338 !-----------------------------------------------------------------------------
2339       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2340 !
2341 ! Soft-sphere potential of p-p interaction
2342 !
2343 !      implicit real*8 (a-h,o-z)
2344 !      include 'DIMENSIONS'
2345 !      include 'COMMON.CONTROL'
2346 !      include 'COMMON.IOUNITS'
2347 !      include 'COMMON.GEO'
2348 !      include 'COMMON.VAR'
2349 !      include 'COMMON.LOCAL'
2350 !      include 'COMMON.CHAIN'
2351 !      include 'COMMON.DERIV'
2352 !      include 'COMMON.INTERACT'
2353 !      include 'COMMON.CONTACTS'
2354 !      include 'COMMON.TORSION'
2355 !      include 'COMMON.VECTORS'
2356 !      include 'COMMON.FFIELD'
2357       real(kind=8),dimension(3) :: ggg
2358 !d      write(iout,*) 'In EELEC_soft_sphere'
2359 !el local variables
2360       integer :: i,j,k,num_conti,iteli,itelj
2361       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2362       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2363       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2364
2365       ees=0.0D0
2366       evdw1=0.0D0
2367       eel_loc=0.0d0
2368       eello_turn3=0.0d0
2369       eello_turn4=0.0d0
2370 !el      ind=0
2371       do i=iatel_s,iatel_e
2372         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2373         dxi=dc(1,i)
2374         dyi=dc(2,i)
2375         dzi=dc(3,i)
2376         xmedi=c(1,i)+0.5d0*dxi
2377         ymedi=c(2,i)+0.5d0*dyi
2378         zmedi=c(3,i)+0.5d0*dzi
2379         call to_box(xmedi,ymedi,zmedi)
2380         num_conti=0
2381 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2382         do j=ielstart(i),ielend(i)
2383           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2384 !el          ind=ind+1
2385           iteli=itel(i)
2386           itelj=itel(j)
2387           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2388           r0ij=rpp(iteli,itelj)
2389           r0ijsq=r0ij*r0ij
2390           dxj=dc(1,j)
2391           dyj=dc(2,j)
2392           dzj=dc(3,j)
2393           xj=c(1,j)+0.5D0*dxj-xmedi
2394           yj=c(2,j)+0.5D0*dyj-ymedi
2395           zj=c(3,j)+0.5D0*dzj-zmedi
2396           call to_box(xj,yj,zj)
2397           xj=boxshift(xj-xmedi,boxxsize)
2398           yj=boxshift(yj-ymedi,boxysize)
2399           zj=boxshift(zj-zmedi,boxzsize)
2400           rij=xj*xj+yj*yj+zj*zj
2401           if (rij.lt.r0ijsq) then
2402             evdw1ij=0.25d0*(rij-r0ijsq)**2
2403             fac=rij-r0ijsq
2404           else
2405             evdw1ij=0.0d0
2406             fac=0.0d0
2407           endif
2408           evdw1=evdw1+evdw1ij
2409 !
2410 ! Calculate contributions to the Cartesian gradient.
2411 !
2412           ggg(1)=fac*xj
2413           ggg(2)=fac*yj
2414           ggg(3)=fac*zj
2415           do k=1,3
2416             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2417             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2418           enddo
2419 !
2420 ! Loop over residues i+1 thru j-1.
2421 !
2422 !grad          do k=i+1,j-1
2423 !grad            do l=1,3
2424 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2425 !grad            enddo
2426 !grad          enddo
2427         enddo ! j
2428       enddo   ! i
2429 !grad      do i=nnt,nct-1
2430 !grad        do k=1,3
2431 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2432 !grad        enddo
2433 !grad        do j=i+1,nct-1
2434 !grad          do k=1,3
2435 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2436 !grad          enddo
2437 !grad        enddo
2438 !grad      enddo
2439       return
2440       end subroutine eelec_soft_sphere
2441 !-----------------------------------------------------------------------------
2442       subroutine vec_and_deriv
2443 !      implicit real*8 (a-h,o-z)
2444 !      include 'DIMENSIONS'
2445 #ifdef MPI
2446       include 'mpif.h'
2447 #endif
2448 !      include 'COMMON.IOUNITS'
2449 !      include 'COMMON.GEO'
2450 !      include 'COMMON.VAR'
2451 !      include 'COMMON.LOCAL'
2452 !      include 'COMMON.CHAIN'
2453 !      include 'COMMON.VECTORS'
2454 !      include 'COMMON.SETUP'
2455 !      include 'COMMON.TIME1'
2456       real(kind=8),dimension(3,3,2) :: uyder,uzder
2457       real(kind=8),dimension(2) :: vbld_inv_temp
2458 ! Compute the local reference systems. For reference system (i), the
2459 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2460 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2461 !el local variables
2462       integer :: i,j,k,l
2463       real(kind=8) :: facy,fac,costh
2464
2465 #ifdef PARVEC
2466       do i=ivec_start,ivec_end
2467 #else
2468       do i=1,nres-1
2469 #endif
2470           if (i.eq.nres-1) then
2471 ! Case of the last full residue
2472 ! Compute the Z-axis
2473             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2474             costh=dcos(pi-theta(nres))
2475             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2476             do k=1,3
2477               uz(k,i)=fac*uz(k,i)
2478             enddo
2479 ! Compute the derivatives of uz
2480             uzder(1,1,1)= 0.0d0
2481             uzder(2,1,1)=-dc_norm(3,i-1)
2482             uzder(3,1,1)= dc_norm(2,i-1)
2483             uzder(1,2,1)= dc_norm(3,i-1)
2484             uzder(2,2,1)= 0.0d0
2485             uzder(3,2,1)=-dc_norm(1,i-1)
2486             uzder(1,3,1)=-dc_norm(2,i-1)
2487             uzder(2,3,1)= dc_norm(1,i-1)
2488             uzder(3,3,1)= 0.0d0
2489             uzder(1,1,2)= 0.0d0
2490             uzder(2,1,2)= dc_norm(3,i)
2491             uzder(3,1,2)=-dc_norm(2,i)
2492             uzder(1,2,2)=-dc_norm(3,i)
2493             uzder(2,2,2)= 0.0d0
2494             uzder(3,2,2)= dc_norm(1,i)
2495             uzder(1,3,2)= dc_norm(2,i)
2496             uzder(2,3,2)=-dc_norm(1,i)
2497             uzder(3,3,2)= 0.0d0
2498 ! Compute the Y-axis
2499             facy=fac
2500             do k=1,3
2501               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2502             enddo
2503 ! Compute the derivatives of uy
2504             do j=1,3
2505               do k=1,3
2506                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2507                               -dc_norm(k,i)*dc_norm(j,i-1)
2508                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2509               enddo
2510               uyder(j,j,1)=uyder(j,j,1)-costh
2511               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2512             enddo
2513             do j=1,2
2514               do k=1,3
2515                 do l=1,3
2516                   uygrad(l,k,j,i)=uyder(l,k,j)
2517                   uzgrad(l,k,j,i)=uzder(l,k,j)
2518                 enddo
2519               enddo
2520             enddo
2521             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2522             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2523             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2524             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2525           else
2526 ! Other residues
2527 ! Compute the Z-axis
2528             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2529             costh=dcos(pi-theta(i+2))
2530             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2531             do k=1,3
2532               uz(k,i)=fac*uz(k,i)
2533             enddo
2534 ! Compute the derivatives of uz
2535             uzder(1,1,1)= 0.0d0
2536             uzder(2,1,1)=-dc_norm(3,i+1)
2537             uzder(3,1,1)= dc_norm(2,i+1)
2538             uzder(1,2,1)= dc_norm(3,i+1)
2539             uzder(2,2,1)= 0.0d0
2540             uzder(3,2,1)=-dc_norm(1,i+1)
2541             uzder(1,3,1)=-dc_norm(2,i+1)
2542             uzder(2,3,1)= dc_norm(1,i+1)
2543             uzder(3,3,1)= 0.0d0
2544             uzder(1,1,2)= 0.0d0
2545             uzder(2,1,2)= dc_norm(3,i)
2546             uzder(3,1,2)=-dc_norm(2,i)
2547             uzder(1,2,2)=-dc_norm(3,i)
2548             uzder(2,2,2)= 0.0d0
2549             uzder(3,2,2)= dc_norm(1,i)
2550             uzder(1,3,2)= dc_norm(2,i)
2551             uzder(2,3,2)=-dc_norm(1,i)
2552             uzder(3,3,2)= 0.0d0
2553 ! Compute the Y-axis
2554             facy=fac
2555             do k=1,3
2556               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2557             enddo
2558 ! Compute the derivatives of uy
2559             do j=1,3
2560               do k=1,3
2561                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2562                               -dc_norm(k,i)*dc_norm(j,i+1)
2563                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2564               enddo
2565               uyder(j,j,1)=uyder(j,j,1)-costh
2566               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2567             enddo
2568             do j=1,2
2569               do k=1,3
2570                 do l=1,3
2571                   uygrad(l,k,j,i)=uyder(l,k,j)
2572                   uzgrad(l,k,j,i)=uzder(l,k,j)
2573                 enddo
2574               enddo
2575             enddo
2576             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2577             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2578             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2579             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2580           endif
2581       enddo
2582       do i=1,nres-1
2583         vbld_inv_temp(1)=vbld_inv(i+1)
2584         if (i.lt.nres-1) then
2585           vbld_inv_temp(2)=vbld_inv(i+2)
2586           else
2587           vbld_inv_temp(2)=vbld_inv(i)
2588           endif
2589         do j=1,2
2590           do k=1,3
2591             do l=1,3
2592               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2593               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2594             enddo
2595           enddo
2596         enddo
2597       enddo
2598 #if defined(PARVEC) && defined(MPI)
2599       if (nfgtasks1.gt.1) then
2600         time00=MPI_Wtime()
2601 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2602 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2603 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2604         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2605          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2606          FG_COMM1,IERR)
2607         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2608          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2609          FG_COMM1,IERR)
2610         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2611          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2612          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2613         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2614          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2615          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2616         time_gather=time_gather+MPI_Wtime()-time00
2617       endif
2618 !      if (fg_rank.eq.0) then
2619 !        write (iout,*) "Arrays UY and UZ"
2620 !        do i=1,nres-1
2621 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2622 !     &     (uz(k,i),k=1,3)
2623 !        enddo
2624 !      endif
2625 #endif
2626       return
2627       end subroutine vec_and_deriv
2628 !-----------------------------------------------------------------------------
2629       subroutine check_vecgrad
2630 !      implicit real*8 (a-h,o-z)
2631 !      include 'DIMENSIONS'
2632 !      include 'COMMON.IOUNITS'
2633 !      include 'COMMON.GEO'
2634 !      include 'COMMON.VAR'
2635 !      include 'COMMON.LOCAL'
2636 !      include 'COMMON.CHAIN'
2637 !      include 'COMMON.VECTORS'
2638       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2639       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2640       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2641       real(kind=8),dimension(3) :: erij
2642       real(kind=8) :: delta=1.0d-7
2643 !el local variables
2644       integer :: i,j,k,l
2645
2646       call vec_and_deriv
2647 !d      do i=1,nres
2648 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2649 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2650 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2651 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2652 !d     &     (dc_norm(if90,i),if90=1,3)
2653 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2654 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2655 !d          write(iout,'(a)')
2656 !d      enddo
2657       do i=1,nres
2658         do j=1,2
2659           do k=1,3
2660             do l=1,3
2661               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2662               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2663             enddo
2664           enddo
2665         enddo
2666       enddo
2667       call vec_and_deriv
2668       do i=1,nres
2669         do j=1,3
2670           uyt(j,i)=uy(j,i)
2671           uzt(j,i)=uz(j,i)
2672         enddo
2673       enddo
2674       do i=1,nres
2675 !d        write (iout,*) 'i=',i
2676         do k=1,3
2677           erij(k)=dc_norm(k,i)
2678         enddo
2679         do j=1,3
2680           do k=1,3
2681             dc_norm(k,i)=erij(k)
2682           enddo
2683           dc_norm(j,i)=dc_norm(j,i)+delta
2684 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2685 !          do k=1,3
2686 !            dc_norm(k,i)=dc_norm(k,i)/fac
2687 !          enddo
2688 !          write (iout,*) (dc_norm(k,i),k=1,3)
2689 !          write (iout,*) (erij(k),k=1,3)
2690           call vec_and_deriv
2691           do k=1,3
2692             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2693             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2694             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2695             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2696           enddo
2697 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2698 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2699 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2700         enddo
2701         do k=1,3
2702           dc_norm(k,i)=erij(k)
2703         enddo
2704 !d        do k=1,3
2705 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2706 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2707 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2708 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2709 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2710 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2711 !d          write (iout,'(a)')
2712 !d        enddo
2713       enddo
2714       return
2715       end subroutine check_vecgrad
2716 !-----------------------------------------------------------------------------
2717       subroutine set_matrices
2718 !      implicit real*8 (a-h,o-z)
2719 !      include 'DIMENSIONS'
2720 #ifdef MPI
2721       include "mpif.h"
2722 !      include "COMMON.SETUP"
2723       integer :: IERR
2724       integer :: status(MPI_STATUS_SIZE)
2725 #endif
2726 !      include 'COMMON.IOUNITS'
2727 !      include 'COMMON.GEO'
2728 !      include 'COMMON.VAR'
2729 !      include 'COMMON.LOCAL'
2730 !      include 'COMMON.CHAIN'
2731 !      include 'COMMON.DERIV'
2732 !      include 'COMMON.INTERACT'
2733 !      include 'COMMON.CONTACTS'
2734 !      include 'COMMON.TORSION'
2735 !      include 'COMMON.VECTORS'
2736 !      include 'COMMON.FFIELD'
2737       real(kind=8) :: auxvec(2),auxmat(2,2)
2738       integer :: i,iti1,iti,k,l
2739       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2740        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2741 !       print *,"in set matrices"
2742 !
2743 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2744 ! to calculate the el-loc multibody terms of various order.
2745 !
2746 !AL el      mu=0.0d0
2747
2748 #ifdef PARMAT
2749       do i=ivec_start+2,ivec_end+2
2750 #else
2751       do i=3,nres+1
2752 #endif
2753         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2754           if (itype(i-2,1).eq.0) then
2755           iti = nloctyp
2756           else
2757           iti = itype2loc(itype(i-2,1))
2758           endif
2759         else
2760           iti=nloctyp
2761         endif
2762 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2763         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2764           iti1 = itype2loc(itype(i-1,1))
2765         else
2766           iti1=nloctyp
2767         endif
2768 !        print *,i,itype(i-2,1),iti
2769 #ifdef NEWCORR
2770         cost1=dcos(theta(i-1))
2771         sint1=dsin(theta(i-1))
2772         sint1sq=sint1*sint1
2773         sint1cub=sint1sq*sint1
2774         sint1cost1=2*sint1*cost1
2775 !        print *,"cost1",cost1,theta(i-1)
2776 !c        write (iout,*) "bnew1",i,iti
2777 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2778 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2779 !c        write (iout,*) "bnew2",i,iti
2780 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2781 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2782         k=1
2783 !        print *,bnew1(1,k,iti),"bnew1"
2784         do k=1,2
2785           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2786 !          print *,b1k
2787 !          write(*,*) shape(b1)
2788 !          if(.not.allocated(b1)) print *, "WTF?"
2789           b1(k,i-2)=sint1*b1k
2790 !
2791 !             print *,b1(k,i-2)
2792
2793           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2794                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2795 !             print *,gtb1(k,i-2)
2796
2797           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2798           b2(k,i-2)=sint1*b2k
2799 !             print *,b2(k,i-2)
2800
2801           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2802                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2803 !             print *,gtb2(k,i-2)
2804
2805         enddo
2806 !        print *,b1k,b2k
2807         do k=1,2
2808           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2809           cc(1,k,i-2)=sint1sq*aux
2810           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2811                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2812           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2813           dd(1,k,i-2)=sint1sq*aux
2814           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2815                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2816         enddo
2817 !        print *,"after cc"
2818         cc(2,1,i-2)=cc(1,2,i-2)
2819         cc(2,2,i-2)=-cc(1,1,i-2)
2820         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2821         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2822         dd(2,1,i-2)=dd(1,2,i-2)
2823         dd(2,2,i-2)=-dd(1,1,i-2)
2824         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2825         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2826 !        print *,"after dd"
2827
2828         do k=1,2
2829           do l=1,2
2830             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2831             EE(l,k,i-2)=sint1sq*aux
2832             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2833           enddo
2834         enddo
2835         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2836         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2837         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2838         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2839         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2840         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2841         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2842 !        print *,"after ee"
2843
2844 !c        b1tilde(1,i-2)=b1(1,i-2)
2845 !c        b1tilde(2,i-2)=-b1(2,i-2)
2846 !c        b2tilde(1,i-2)=b2(1,i-2)
2847 !c        b2tilde(2,i-2)=-b2(2,i-2)
2848 #ifdef DEBUG
2849         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2850         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2851         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2852         write (iout,*) 'theta=', theta(i-1)
2853 #endif
2854 #else
2855         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2856 !         write(iout,*) "i,",molnum(i),nloctyp
2857 !         print *, "i,",molnum(i),i,itype(i-2,1)
2858         if (molnum(i).eq.1) then
2859           if (itype(i-2,1).eq.ntyp1) then
2860            iti=nloctyp
2861           else
2862           iti = itype2loc(itype(i-2,1))
2863           endif
2864         else
2865           iti=nloctyp
2866         endif
2867         else
2868           iti=nloctyp
2869         endif
2870 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2871 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2872         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2873           iti1 = itype2loc(itype(i-1,1))
2874         else
2875           iti1=nloctyp
2876         endif
2877 !        print *,i,iti
2878         b1(1,i-2)=b(3,iti)
2879         b1(2,i-2)=b(5,iti)
2880         b2(1,i-2)=b(2,iti)
2881         b2(2,i-2)=b(4,iti)
2882         do k=1,2
2883           do l=1,2
2884            CC(k,l,i-2)=ccold(k,l,iti)
2885            DD(k,l,i-2)=ddold(k,l,iti)
2886            EE(k,l,i-2)=eeold(k,l,iti)
2887           enddo
2888         enddo
2889 #endif
2890         b1tilde(1,i-2)= b1(1,i-2)
2891         b1tilde(2,i-2)=-b1(2,i-2)
2892         b2tilde(1,i-2)= b2(1,i-2)
2893         b2tilde(2,i-2)=-b2(2,i-2)
2894 !c
2895         Ctilde(1,1,i-2)= CC(1,1,i-2)
2896         Ctilde(1,2,i-2)= CC(1,2,i-2)
2897         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2898         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2899 !c
2900         Dtilde(1,1,i-2)= DD(1,1,i-2)
2901         Dtilde(1,2,i-2)= DD(1,2,i-2)
2902         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2903         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2904       enddo
2905 #ifdef PARMAT
2906       do i=ivec_start+2,ivec_end+2
2907 #else
2908       do i=3,nres+1
2909 #endif
2910
2911 !      print *,i,"i"
2912         if (i .lt. nres+1) then
2913           sin1=dsin(phi(i))
2914           cos1=dcos(phi(i))
2915           sintab(i-2)=sin1
2916           costab(i-2)=cos1
2917           obrot(1,i-2)=cos1
2918           obrot(2,i-2)=sin1
2919           sin2=dsin(2*phi(i))
2920           cos2=dcos(2*phi(i))
2921           sintab2(i-2)=sin2
2922           costab2(i-2)=cos2
2923           obrot2(1,i-2)=cos2
2924           obrot2(2,i-2)=sin2
2925           Ug(1,1,i-2)=-cos1
2926           Ug(1,2,i-2)=-sin1
2927           Ug(2,1,i-2)=-sin1
2928           Ug(2,2,i-2)= cos1
2929           Ug2(1,1,i-2)=-cos2
2930           Ug2(1,2,i-2)=-sin2
2931           Ug2(2,1,i-2)=-sin2
2932           Ug2(2,2,i-2)= cos2
2933         else
2934           costab(i-2)=1.0d0
2935           sintab(i-2)=0.0d0
2936           obrot(1,i-2)=1.0d0
2937           obrot(2,i-2)=0.0d0
2938           obrot2(1,i-2)=0.0d0
2939           obrot2(2,i-2)=0.0d0
2940           Ug(1,1,i-2)=1.0d0
2941           Ug(1,2,i-2)=0.0d0
2942           Ug(2,1,i-2)=0.0d0
2943           Ug(2,2,i-2)=1.0d0
2944           Ug2(1,1,i-2)=0.0d0
2945           Ug2(1,2,i-2)=0.0d0
2946           Ug2(2,1,i-2)=0.0d0
2947           Ug2(2,2,i-2)=0.0d0
2948         endif
2949         if (i .gt. 3 .and. i .lt. nres+1) then
2950           obrot_der(1,i-2)=-sin1
2951           obrot_der(2,i-2)= cos1
2952           Ugder(1,1,i-2)= sin1
2953           Ugder(1,2,i-2)=-cos1
2954           Ugder(2,1,i-2)=-cos1
2955           Ugder(2,2,i-2)=-sin1
2956           dwacos2=cos2+cos2
2957           dwasin2=sin2+sin2
2958           obrot2_der(1,i-2)=-dwasin2
2959           obrot2_der(2,i-2)= dwacos2
2960           Ug2der(1,1,i-2)= dwasin2
2961           Ug2der(1,2,i-2)=-dwacos2
2962           Ug2der(2,1,i-2)=-dwacos2
2963           Ug2der(2,2,i-2)=-dwasin2
2964         else
2965           obrot_der(1,i-2)=0.0d0
2966           obrot_der(2,i-2)=0.0d0
2967           Ugder(1,1,i-2)=0.0d0
2968           Ugder(1,2,i-2)=0.0d0
2969           Ugder(2,1,i-2)=0.0d0
2970           Ugder(2,2,i-2)=0.0d0
2971           obrot2_der(1,i-2)=0.0d0
2972           obrot2_der(2,i-2)=0.0d0
2973           Ug2der(1,1,i-2)=0.0d0
2974           Ug2der(1,2,i-2)=0.0d0
2975           Ug2der(2,1,i-2)=0.0d0
2976           Ug2der(2,2,i-2)=0.0d0
2977         endif
2978 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2979         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2980            if (itype(i-2,1).eq.0) then
2981           iti=ntortyp+1
2982            else
2983           iti = itype2loc(itype(i-2,1))
2984            endif
2985         else
2986           iti=nloctyp
2987         endif
2988 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2989         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2990            if (itype(i-1,1).eq.0) then
2991           iti1=nloctyp
2992            else
2993           iti1 = itype2loc(itype(i-1,1))
2994            endif
2995         else
2996           iti1=nloctyp
2997         endif
2998 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2999 !d        write (iout,*) '*******i',i,' iti1',iti
3000 !        write (iout,*) 'b1',b1(:,iti)
3001 !        write (iout,*) 'b2',b2(:,i-2)
3002 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3003 !        if (i .gt. iatel_s+2) then
3004         if (i .gt. nnt+2) then
3005           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3006 #ifdef NEWCORR
3007           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3008 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3009 #endif
3010
3011           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3012           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3013           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3014           then
3015           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3016           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3017           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3018           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3019           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3020           endif
3021         else
3022           do k=1,2
3023             Ub2(k,i-2)=0.0d0
3024             Ctobr(k,i-2)=0.0d0
3025             Dtobr2(k,i-2)=0.0d0
3026             do l=1,2
3027               EUg(l,k,i-2)=0.0d0
3028               CUg(l,k,i-2)=0.0d0
3029               DUg(l,k,i-2)=0.0d0
3030               DtUg2(l,k,i-2)=0.0d0
3031             enddo
3032           enddo
3033         endif
3034         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3035         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3036         do k=1,2
3037           muder(k,i-2)=Ub2der(k,i-2)
3038         enddo
3039 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3040         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3041           if (itype(i-1,1).eq.0) then
3042            iti1=nloctyp
3043           elseif (itype(i-1,1).le.ntyp) then
3044             iti1 = itype2loc(itype(i-1,1))
3045           else
3046             iti1=nloctyp
3047           endif
3048         else
3049           iti1=nloctyp
3050         endif
3051         do k=1,2
3052           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3053         enddo
3054         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3055         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3056         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3057 !d        write (iout,*) 'mu1',mu1(:,i-2)
3058 !d        write (iout,*) 'mu2',mu2(:,i-2)
3059         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3060         then
3061         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3062         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3063         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3064         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3065         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3066 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3067         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3068         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3069         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3070         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3071         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3072         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3073         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3074         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3075         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3076         endif
3077       enddo
3078 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3079 ! The order of matrices is from left to right.
3080       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3081       then
3082 !      do i=max0(ivec_start,2),ivec_end
3083       do i=2,nres-1
3084         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3085         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3086         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3087         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3088         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3089         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3090         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3091         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3092       enddo
3093       endif
3094 #if defined(MPI) && defined(PARMAT)
3095 #ifdef DEBUG
3096 !      if (fg_rank.eq.0) then
3097         write (iout,*) "Arrays UG and UGDER before GATHER"
3098         do i=1,nres-1
3099           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3100            ((ug(l,k,i),l=1,2),k=1,2),&
3101            ((ugder(l,k,i),l=1,2),k=1,2)
3102         enddo
3103         write (iout,*) "Arrays UG2 and UG2DER"
3104         do i=1,nres-1
3105           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3106            ((ug2(l,k,i),l=1,2),k=1,2),&
3107            ((ug2der(l,k,i),l=1,2),k=1,2)
3108         enddo
3109         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3110         do i=1,nres-1
3111           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3112            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3113            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3114         enddo
3115         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3116         do i=1,nres-1
3117           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3118            costab(i),sintab(i),costab2(i),sintab2(i)
3119         enddo
3120         write (iout,*) "Array MUDER"
3121         do i=1,nres-1
3122           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3123         enddo
3124 !      endif
3125 #endif
3126       if (nfgtasks.gt.1) then
3127         time00=MPI_Wtime()
3128 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3129 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3130 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3131 #ifdef MATGATHER
3132         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3133          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3134          FG_COMM1,IERR)
3135         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3136          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3137          FG_COMM1,IERR)
3138         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3139          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3140          FG_COMM1,IERR)
3141         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3142          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3143          FG_COMM1,IERR)
3144         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3145          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3146          FG_COMM1,IERR)
3147         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3148          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3149          FG_COMM1,IERR)
3150         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3151          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3152          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3153         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3154          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3155          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3156         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3157          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3158          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3159         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3160          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3161          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3162         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3163         then
3164         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3165          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3166          FG_COMM1,IERR)
3167         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3168          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3169          FG_COMM1,IERR)
3170         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3171          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3172          FG_COMM1,IERR)
3173        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3174          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3175          FG_COMM1,IERR)
3176         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3177          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3178          FG_COMM1,IERR)
3179         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3180          ivec_count(fg_rank1),&
3181          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3182          FG_COMM1,IERR)
3183         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3184          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3185          FG_COMM1,IERR)
3186         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3187          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3188          FG_COMM1,IERR)
3189         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3190          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3191          FG_COMM1,IERR)
3192         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3193          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3194          FG_COMM1,IERR)
3195         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3196          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3197          FG_COMM1,IERR)
3198         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3199          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3200          FG_COMM1,IERR)
3201         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3202          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3203          FG_COMM1,IERR)
3204         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3205          ivec_count(fg_rank1),&
3206          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3207          FG_COMM1,IERR)
3208         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3209          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3210          FG_COMM1,IERR)
3211        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3212          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3213          FG_COMM1,IERR)
3214         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3215          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3216          FG_COMM1,IERR)
3217        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3218          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3219          FG_COMM1,IERR)
3220         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3221          ivec_count(fg_rank1),&
3222          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3223          FG_COMM1,IERR)
3224         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3225          ivec_count(fg_rank1),&
3226          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3227          FG_COMM1,IERR)
3228         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3229          ivec_count(fg_rank1),&
3230          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3231          MPI_MAT2,FG_COMM1,IERR)
3232         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3233          ivec_count(fg_rank1),&
3234          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3235          MPI_MAT2,FG_COMM1,IERR)
3236         endif
3237 #else
3238 ! Passes matrix info through the ring
3239       isend=fg_rank1
3240       irecv=fg_rank1-1
3241       if (irecv.lt.0) irecv=nfgtasks1-1
3242       iprev=irecv
3243       inext=fg_rank1+1
3244       if (inext.ge.nfgtasks1) inext=0
3245       do i=1,nfgtasks1-1
3246 !        write (iout,*) "isend",isend," irecv",irecv
3247 !        call flush(iout)
3248         lensend=lentyp(isend)
3249         lenrecv=lentyp(irecv)
3250 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3251 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3252 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3253 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3254 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3255 !        write (iout,*) "Gather ROTAT1"
3256 !        call flush(iout)
3257 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3258 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3259 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3260 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3261 !        write (iout,*) "Gather ROTAT2"
3262 !        call flush(iout)
3263         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3264          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3265          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3266          iprev,4400+irecv,FG_COMM,status,IERR)
3267 !        write (iout,*) "Gather ROTAT_OLD"
3268 !        call flush(iout)
3269         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3270          MPI_PRECOMP11(lensend),inext,5500+isend,&
3271          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3272          iprev,5500+irecv,FG_COMM,status,IERR)
3273 !        write (iout,*) "Gather PRECOMP11"
3274 !        call flush(iout)
3275         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3276          MPI_PRECOMP12(lensend),inext,6600+isend,&
3277          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3278          iprev,6600+irecv,FG_COMM,status,IERR)
3279 !        write (iout,*) "Gather PRECOMP12"
3280 !        call flush(iout)
3281         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3282         then
3283         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3284          MPI_ROTAT2(lensend),inext,7700+isend,&
3285          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3286          iprev,7700+irecv,FG_COMM,status,IERR)
3287 !        write (iout,*) "Gather PRECOMP21"
3288 !        call flush(iout)
3289         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3290          MPI_PRECOMP22(lensend),inext,8800+isend,&
3291          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3292          iprev,8800+irecv,FG_COMM,status,IERR)
3293 !        write (iout,*) "Gather PRECOMP22"
3294 !        call flush(iout)
3295         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3296          MPI_PRECOMP23(lensend),inext,9900+isend,&
3297          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3298          MPI_PRECOMP23(lenrecv),&
3299          iprev,9900+irecv,FG_COMM,status,IERR)
3300 !        write (iout,*) "Gather PRECOMP23"
3301 !        call flush(iout)
3302         endif
3303         isend=irecv
3304         irecv=irecv-1
3305         if (irecv.lt.0) irecv=nfgtasks1-1
3306       enddo
3307 #endif
3308         time_gather=time_gather+MPI_Wtime()-time00
3309       endif
3310 #ifdef DEBUG
3311 !      if (fg_rank.eq.0) then
3312         write (iout,*) "Arrays UG and UGDER"
3313         do i=1,nres-1
3314           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3315            ((ug(l,k,i),l=1,2),k=1,2),&
3316            ((ugder(l,k,i),l=1,2),k=1,2)
3317         enddo
3318         write (iout,*) "Arrays UG2 and UG2DER"
3319         do i=1,nres-1
3320           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3321            ((ug2(l,k,i),l=1,2),k=1,2),&
3322            ((ug2der(l,k,i),l=1,2),k=1,2)
3323         enddo
3324         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3325         do i=1,nres-1
3326           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3327            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3328            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3329         enddo
3330         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3331         do i=1,nres-1
3332           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3333            costab(i),sintab(i),costab2(i),sintab2(i)
3334         enddo
3335         write (iout,*) "Array MUDER"
3336         do i=1,nres-1
3337           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3338         enddo
3339 !      endif
3340 #endif
3341 #endif
3342 !d      do i=1,nres
3343 !d        iti = itortyp(itype(i,1))
3344 !d        write (iout,*) i
3345 !d        do j=1,2
3346 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3347 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3348 !d        enddo
3349 !d      enddo
3350       return
3351       end subroutine set_matrices
3352 !-----------------------------------------------------------------------------
3353       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3354 !
3355 ! This subroutine calculates the average interaction energy and its gradient
3356 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3357 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3358 ! The potential depends both on the distance of peptide-group centers and on
3359 ! the orientation of the CA-CA virtual bonds.
3360 !
3361       use comm_locel
3362 !      implicit real*8 (a-h,o-z)
3363 #ifdef MPI
3364       include 'mpif.h'
3365 #endif
3366 !      include 'DIMENSIONS'
3367 !      include 'COMMON.CONTROL'
3368 !      include 'COMMON.SETUP'
3369 !      include 'COMMON.IOUNITS'
3370 !      include 'COMMON.GEO'
3371 !      include 'COMMON.VAR'
3372 !      include 'COMMON.LOCAL'
3373 !      include 'COMMON.CHAIN'
3374 !      include 'COMMON.DERIV'
3375 !      include 'COMMON.INTERACT'
3376 !      include 'COMMON.CONTACTS'
3377 !      include 'COMMON.TORSION'
3378 !      include 'COMMON.VECTORS'
3379 !      include 'COMMON.FFIELD'
3380 !      include 'COMMON.TIME1'
3381       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3382       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3383       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3384 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3385       real(kind=8),dimension(4) :: muij
3386 !el      integer :: num_conti,j1,j2
3387 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3388 !el        dz_normi,xmedi,ymedi,zmedi
3389
3390 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3391 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3392 !el          num_conti,j1,j2
3393
3394 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3395 #ifdef MOMENT
3396       real(kind=8) :: scal_el=1.0d0
3397 #else
3398       real(kind=8) :: scal_el=0.5d0
3399 #endif
3400 ! 12/13/98
3401 ! 13-go grudnia roku pamietnego...
3402       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3403                                              0.0d0,1.0d0,0.0d0,&
3404                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3405 !el local variables
3406       integer :: i,k,j,icont
3407       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3408       real(kind=8) :: fac,t_eelecij,fracinbuf
3409
3410
3411 !d      write(iout,*) 'In EELEC'
3412 !        print *,"IN EELEC"
3413 !d      do i=1,nloctyp
3414 !d        write(iout,*) 'Type',i
3415 !d        write(iout,*) 'B1',B1(:,i)
3416 !d        write(iout,*) 'B2',B2(:,i)
3417 !d        write(iout,*) 'CC',CC(:,:,i)
3418 !d        write(iout,*) 'DD',DD(:,:,i)
3419 !d        write(iout,*) 'EE',EE(:,:,i)
3420 !d      enddo
3421 !d      call check_vecgrad
3422 !d      stop
3423 !      ees=0.0d0  !AS
3424 !      evdw1=0.0d0
3425 !      eel_loc=0.0d0
3426 !      eello_turn3=0.0d0
3427 !      eello_turn4=0.0d0
3428       t_eelecij=0.0d0
3429       ees=0.0D0
3430       evdw1=0.0D0
3431       eel_loc=0.0d0
3432       eello_turn3=0.0d0
3433       eello_turn4=0.0d0
3434 !
3435
3436       if (icheckgrad.eq.1) then
3437 !el
3438 !        do i=0,2*nres+2
3439 !          dc_norm(1,i)=0.0d0
3440 !          dc_norm(2,i)=0.0d0
3441 !          dc_norm(3,i)=0.0d0
3442 !        enddo
3443         do i=1,nres-1
3444           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3445           do k=1,3
3446             dc_norm(k,i)=dc(k,i)*fac
3447           enddo
3448 !          write (iout,*) 'i',i,' fac',fac
3449         enddo
3450       endif
3451 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3452 !        wturn6
3453       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3454           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3455           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3456 !        call vec_and_deriv
3457 #ifdef TIMING
3458         time01=MPI_Wtime()
3459 #endif
3460 !        print *, "before set matrices"
3461         call set_matrices
3462 !        print *, "after set matrices"
3463
3464 #ifdef TIMING
3465         time_mat=time_mat+MPI_Wtime()-time01
3466 #endif
3467       endif
3468 !       print *, "after set matrices"
3469 !d      do i=1,nres-1
3470 !d        write (iout,*) 'i=',i
3471 !d        do k=1,3
3472 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3473 !d        enddo
3474 !d        do k=1,3
3475 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3476 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3477 !d        enddo
3478 !d      enddo
3479       t_eelecij=0.0d0
3480       ees=0.0D0
3481       evdw1=0.0D0
3482       eel_loc=0.0d0
3483       eello_turn3=0.0d0
3484       eello_turn4=0.0d0
3485 !el      ind=0
3486       do i=1,nres
3487         num_cont_hb(i)=0
3488       enddo
3489 !d      print '(a)','Enter EELEC'
3490 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3491 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3492 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3493       do i=1,nres
3494         gel_loc_loc(i)=0.0d0
3495         gcorr_loc(i)=0.0d0
3496       enddo
3497 !
3498 !
3499 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3500 !
3501 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3502 !
3503
3504
3505 !        print *,"before iturn3 loop"
3506       do i=iturn3_start,iturn3_end
3507         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3508         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3509         dxi=dc(1,i)
3510         dyi=dc(2,i)
3511         dzi=dc(3,i)
3512         dx_normi=dc_norm(1,i)
3513         dy_normi=dc_norm(2,i)
3514         dz_normi=dc_norm(3,i)
3515         xmedi=c(1,i)+0.5d0*dxi
3516         ymedi=c(2,i)+0.5d0*dyi
3517         zmedi=c(3,i)+0.5d0*dzi
3518         call to_box(xmedi,ymedi,zmedi)
3519         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3520         num_conti=0
3521        call eelecij(i,i+2,ees,evdw1,eel_loc)
3522         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3523         num_cont_hb(i)=num_conti
3524       enddo
3525       do i=iturn4_start,iturn4_end
3526         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3527           .or. itype(i+3,1).eq.ntyp1 &
3528           .or. itype(i+4,1).eq.ntyp1) cycle
3529 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3530         dxi=dc(1,i)
3531         dyi=dc(2,i)
3532         dzi=dc(3,i)
3533         dx_normi=dc_norm(1,i)
3534         dy_normi=dc_norm(2,i)
3535         dz_normi=dc_norm(3,i)
3536         xmedi=c(1,i)+0.5d0*dxi
3537         ymedi=c(2,i)+0.5d0*dyi
3538         zmedi=c(3,i)+0.5d0*dzi
3539         call to_box(xmedi,ymedi,zmedi)
3540         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3541         num_conti=num_cont_hb(i)
3542         call eelecij(i,i+3,ees,evdw1,eel_loc)
3543         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3544         call eturn4(i,eello_turn4)
3545 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3546         num_cont_hb(i)=num_conti
3547       enddo   ! i
3548 !
3549 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3550 !
3551 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3552 !      do i=iatel_s,iatel_e
3553 ! JPRDLC
3554        do icont=g_listpp_start,g_listpp_end
3555         i=newcontlistppi(icont)
3556         j=newcontlistppj(icont)
3557         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3558         dxi=dc(1,i)
3559         dyi=dc(2,i)
3560         dzi=dc(3,i)
3561         dx_normi=dc_norm(1,i)
3562         dy_normi=dc_norm(2,i)
3563         dz_normi=dc_norm(3,i)
3564         xmedi=c(1,i)+0.5d0*dxi
3565         ymedi=c(2,i)+0.5d0*dyi
3566         zmedi=c(3,i)+0.5d0*dzi
3567         call to_box(xmedi,ymedi,zmedi)
3568         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3569
3570 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3571         num_conti=num_cont_hb(i)
3572 !        do j=ielstart(i),ielend(i)
3573 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3574           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3575           call eelecij(i,j,ees,evdw1,eel_loc)
3576 !        enddo ! j
3577         num_cont_hb(i)=num_conti
3578       enddo   ! i
3579 !      write (iout,*) "Number of loop steps in EELEC:",ind
3580 !d      do i=1,nres
3581 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3582 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3583 !d      enddo
3584 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3585 !cc      eel_loc=eel_loc+eello_turn3
3586 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3587       return
3588       end subroutine eelec
3589 !-----------------------------------------------------------------------------
3590       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3591
3592       use comm_locel
3593 !      implicit real*8 (a-h,o-z)
3594 !      include 'DIMENSIONS'
3595 #ifdef MPI
3596       include "mpif.h"
3597 #endif
3598 !      include 'COMMON.CONTROL'
3599 !      include 'COMMON.IOUNITS'
3600 !      include 'COMMON.GEO'
3601 !      include 'COMMON.VAR'
3602 !      include 'COMMON.LOCAL'
3603 !      include 'COMMON.CHAIN'
3604 !      include 'COMMON.DERIV'
3605 !      include 'COMMON.INTERACT'
3606 !      include 'COMMON.CONTACTS'
3607 !      include 'COMMON.TORSION'
3608 !      include 'COMMON.VECTORS'
3609 !      include 'COMMON.FFIELD'
3610 !      include 'COMMON.TIME1'
3611       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3612       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3613       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3614 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3615       real(kind=8),dimension(4) :: muij
3616       real(kind=8) :: geel_loc_ij,geel_loc_ji
3617       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3618                     dist_temp, dist_init,rlocshield,fracinbuf
3619       integer xshift,yshift,zshift,ilist,iresshield
3620 !el      integer :: num_conti,j1,j2
3621 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3622 !el        dz_normi,xmedi,ymedi,zmedi
3623
3624 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3625 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3626 !el          num_conti,j1,j2
3627
3628 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3629 #ifdef MOMENT
3630       real(kind=8) :: scal_el=1.0d0
3631 #else
3632       real(kind=8) :: scal_el=0.5d0
3633 #endif
3634 ! 12/13/98
3635 ! 13-go grudnia roku pamietnego...
3636       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3637                                              0.0d0,1.0d0,0.0d0,&
3638                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3639 !      integer :: maxconts=nres/4
3640 !el local variables
3641       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3642       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3643       real(kind=8) ::  faclipij2, faclipij
3644       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3645       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3646                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3647                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3648                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3649                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3650                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3651                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3652                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3653 !      maxconts=nres/4
3654 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3655 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3656
3657 !          time00=MPI_Wtime()
3658 !d      write (iout,*) "eelecij",i,j
3659 !          ind=ind+1
3660           iteli=itel(i)
3661           itelj=itel(j)
3662           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3663           aaa=app(iteli,itelj)
3664           bbb=bpp(iteli,itelj)
3665           ael6i=ael6(iteli,itelj)
3666           ael3i=ael3(iteli,itelj)
3667           dxj=dc(1,j)
3668           dyj=dc(2,j)
3669           dzj=dc(3,j)
3670           dx_normj=dc_norm(1,j)
3671           dy_normj=dc_norm(2,j)
3672           dz_normj=dc_norm(3,j)
3673 !          xj=c(1,j)+0.5D0*dxj-xmedi
3674 !          yj=c(2,j)+0.5D0*dyj-ymedi
3675 !          zj=c(3,j)+0.5D0*dzj-zmedi
3676           xj=c(1,j)+0.5D0*dxj
3677           yj=c(2,j)+0.5D0*dyj
3678           zj=c(3,j)+0.5D0*dzj
3679
3680           call to_box(xj,yj,zj)
3681           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3682           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3683           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3684           xj=boxshift(xj-xmedi,boxxsize)
3685           yj=boxshift(yj-ymedi,boxysize)
3686           zj=boxshift(zj-zmedi,boxzsize)
3687
3688           rij=xj*xj+yj*yj+zj*zj
3689           rrmij=1.0D0/rij
3690           rij=dsqrt(rij)
3691 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3692             sss_ele_cut=sscale_ele(rij)
3693             sss_ele_grad=sscagrad_ele(rij)
3694 !             sss_ele_cut=1.0d0
3695 !             sss_ele_grad=0.0d0
3696 !            print *,sss_ele_cut,sss_ele_grad,&
3697 !            (rij),r_cut_ele,rlamb_ele
3698             if (sss_ele_cut.le.0.0) go to 128
3699
3700           rmij=1.0D0/rij
3701           r3ij=rrmij*rmij
3702           r6ij=r3ij*r3ij
3703           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3704           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3705           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3706           fac=cosa-3.0D0*cosb*cosg
3707           ev1=aaa*r6ij*r6ij
3708 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3709           if (j.eq.i+2) ev1=scal_el*ev1
3710           ev2=bbb*r6ij
3711           fac3=ael6i*r6ij
3712           fac4=ael3i*r3ij
3713           evdwij=ev1+ev2
3714           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3715           el2=fac4*fac
3716 !          eesij=el1+el2
3717           if (shield_mode.gt.0) then
3718 !C          fac_shield(i)=0.4
3719 !C          fac_shield(j)=0.6
3720           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3721           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3722           eesij=(el1+el2)
3723           ees=ees+eesij*sss_ele_cut
3724 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3725 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3726           else
3727           fac_shield(i)=1.0
3728           fac_shield(j)=1.0
3729           eesij=(el1+el2)
3730           ees=ees+eesij   &
3731             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3732 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3733           endif
3734
3735 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3736           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3737 !          ees=ees+eesij*sss_ele_cut
3738           evdw1=evdw1+evdwij*sss_ele_cut  &
3739            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3740 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3741 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3742 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3743 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3744
3745           if (energy_dec) then
3746 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3747 !                  'evdw1',i,j,evdwij,&
3748 !                  iteli,itelj,aaa,evdw1
3749               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3750               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3751           endif
3752 !
3753 ! Calculate contributions to the Cartesian gradient.
3754 !
3755 #ifdef SPLITELE
3756           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3757               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3758           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3759              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3760           fac1=fac
3761           erij(1)=xj*rmij
3762           erij(2)=yj*rmij
3763           erij(3)=zj*rmij
3764 !
3765 ! Radial derivatives. First process both termini of the fragment (i,j)
3766 !
3767           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3768           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3769           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3770            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3771           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3772             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3773
3774           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3775           (shield_mode.gt.0)) then
3776 !C          print *,i,j
3777           do ilist=1,ishield_list(i)
3778            iresshield=shield_list(ilist,i)
3779            do k=1,3
3780            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3781            *2.0*sss_ele_cut
3782            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3783                    rlocshield &
3784             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3785             *sss_ele_cut
3786             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3787            enddo
3788           enddo
3789           do ilist=1,ishield_list(j)
3790            iresshield=shield_list(ilist,j)
3791            do k=1,3
3792            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3793           *2.0*sss_ele_cut
3794            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3795                    rlocshield &
3796            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3797            *sss_ele_cut
3798            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3799            enddo
3800           enddo
3801           do k=1,3
3802             gshieldc(k,i)=gshieldc(k,i)+ &
3803                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3804            *sss_ele_cut
3805
3806             gshieldc(k,j)=gshieldc(k,j)+ &
3807                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3808            *sss_ele_cut
3809
3810             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3811                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3812            *sss_ele_cut
3813
3814             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3815                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3816            *sss_ele_cut
3817
3818            enddo
3819            endif
3820
3821
3822 !          do k=1,3
3823 !            ghalf=0.5D0*ggg(k)
3824 !            gelc(k,i)=gelc(k,i)+ghalf
3825 !            gelc(k,j)=gelc(k,j)+ghalf
3826 !          enddo
3827 ! 9/28/08 AL Gradient compotents will be summed only at the end
3828           do k=1,3
3829             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3830             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3831           enddo
3832             gelc_long(3,j)=gelc_long(3,j)+  &
3833           ssgradlipj*eesij/2.0d0*lipscale**2&
3834            *sss_ele_cut
3835
3836             gelc_long(3,i)=gelc_long(3,i)+  &
3837           ssgradlipi*eesij/2.0d0*lipscale**2&
3838            *sss_ele_cut
3839
3840
3841 !
3842 ! Loop over residues i+1 thru j-1.
3843 !
3844 !grad          do k=i+1,j-1
3845 !grad            do l=1,3
3846 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3847 !grad            enddo
3848 !grad          enddo
3849           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3850            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3851           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3852            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3853           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3854            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3855
3856 !          do k=1,3
3857 !            ghalf=0.5D0*ggg(k)
3858 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3859 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3860 !          enddo
3861 ! 9/28/08 AL Gradient compotents will be summed only at the end
3862           do k=1,3
3863             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3864             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3865           enddo
3866
3867 !C Lipidic part for scaling weight
3868            gvdwpp(3,j)=gvdwpp(3,j)+ &
3869           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3870            gvdwpp(3,i)=gvdwpp(3,i)+ &
3871           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3872 !! Loop over residues i+1 thru j-1.
3873 !
3874 !grad          do k=i+1,j-1
3875 !grad            do l=1,3
3876 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3877 !grad            enddo
3878 !grad          enddo
3879 #else
3880           facvdw=(ev1+evdwij)*sss_ele_cut &
3881            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3882
3883           facel=(el1+eesij)*sss_ele_cut
3884           fac1=fac
3885           fac=-3*rrmij*(facvdw+facvdw+facel)
3886           erij(1)=xj*rmij
3887           erij(2)=yj*rmij
3888           erij(3)=zj*rmij
3889 !
3890 ! Radial derivatives. First process both termini of the fragment (i,j)
3891 !
3892           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3893           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3894           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3895 !          do k=1,3
3896 !            ghalf=0.5D0*ggg(k)
3897 !            gelc(k,i)=gelc(k,i)+ghalf
3898 !            gelc(k,j)=gelc(k,j)+ghalf
3899 !          enddo
3900 ! 9/28/08 AL Gradient compotents will be summed only at the end
3901           do k=1,3
3902             gelc_long(k,j)=gelc(k,j)+ggg(k)
3903             gelc_long(k,i)=gelc(k,i)-ggg(k)
3904           enddo
3905 !
3906 ! Loop over residues i+1 thru j-1.
3907 !
3908 !grad          do k=i+1,j-1
3909 !grad            do l=1,3
3910 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3911 !grad            enddo
3912 !grad          enddo
3913 ! 9/28/08 AL Gradient compotents will be summed only at the end
3914           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3915            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3916           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3917            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3918           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3919            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3920
3921           do k=1,3
3922             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3923             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3924           enddo
3925            gvdwpp(3,j)=gvdwpp(3,j)+ &
3926           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3927            gvdwpp(3,i)=gvdwpp(3,i)+ &
3928           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3929
3930 #endif
3931 !
3932 ! Angular part
3933 !
3934           ecosa=2.0D0*fac3*fac1+fac4
3935           fac4=-3.0D0*fac4
3936           fac3=-6.0D0*fac3
3937           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3938           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3939           do k=1,3
3940             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3941             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3942           enddo
3943 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3944 !d   &          (dcosg(k),k=1,3)
3945           do k=1,3
3946             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3947              *fac_shield(i)**2*fac_shield(j)**2 &
3948              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3949
3950           enddo
3951 !          do k=1,3
3952 !            ghalf=0.5D0*ggg(k)
3953 !            gelc(k,i)=gelc(k,i)+ghalf
3954 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3955 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3956 !            gelc(k,j)=gelc(k,j)+ghalf
3957 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3958 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3959 !          enddo
3960 !grad          do k=i+1,j-1
3961 !grad            do l=1,3
3962 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3963 !grad            enddo
3964 !grad          enddo
3965           do k=1,3
3966             gelc(k,i)=gelc(k,i) &
3967                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3968                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3969                      *sss_ele_cut &
3970                      *fac_shield(i)**2*fac_shield(j)**2 &
3971                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3972
3973             gelc(k,j)=gelc(k,j) &
3974                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3975                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3976                      *sss_ele_cut  &
3977                      *fac_shield(i)**2*fac_shield(j)**2  &
3978                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3979
3980             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3981             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3982           enddo
3983
3984           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3985               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3986               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3987 !
3988 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3989 !   energy of a peptide unit is assumed in the form of a second-order
3990 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3991 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3992 !   are computed for EVERY pair of non-contiguous peptide groups.
3993 !
3994           if (j.lt.nres-1) then
3995             j1=j+1
3996             j2=j-1
3997           else
3998             j1=j-1
3999             j2=j-2
4000           endif
4001           kkk=0
4002           do k=1,2
4003             do l=1,2
4004               kkk=kkk+1
4005               muij(kkk)=mu(k,i)*mu(l,j)
4006 #ifdef NEWCORR
4007              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4008 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4009              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4010              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4011 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4012              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4013 #endif
4014
4015             enddo
4016           enddo
4017 !d         write (iout,*) 'EELEC: i',i,' j',j
4018 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4019 !d          write(iout,*) 'muij',muij
4020           ury=scalar(uy(1,i),erij)
4021           urz=scalar(uz(1,i),erij)
4022           vry=scalar(uy(1,j),erij)
4023           vrz=scalar(uz(1,j),erij)
4024           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4025           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4026           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4027           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4028           fac=dsqrt(-ael6i)*r3ij
4029           a22=a22*fac
4030           a23=a23*fac
4031           a32=a32*fac
4032           a33=a33*fac
4033 !d          write (iout,'(4i5,4f10.5)')
4034 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4035 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4036 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4037 !d     &      uy(:,j),uz(:,j)
4038 !d          write (iout,'(4f10.5)')
4039 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4040 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4041 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4042 !d           write (iout,'(9f10.5/)')
4043 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4044 ! Derivatives of the elements of A in virtual-bond vectors
4045           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4046           do k=1,3
4047             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4048             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4049             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4050             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4051             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4052             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4053             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4054             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4055             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4056             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4057             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4058             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4059           enddo
4060 ! Compute radial contributions to the gradient
4061           facr=-3.0d0*rrmij
4062           a22der=a22*facr
4063           a23der=a23*facr
4064           a32der=a32*facr
4065           a33der=a33*facr
4066           agg(1,1)=a22der*xj
4067           agg(2,1)=a22der*yj
4068           agg(3,1)=a22der*zj
4069           agg(1,2)=a23der*xj
4070           agg(2,2)=a23der*yj
4071           agg(3,2)=a23der*zj
4072           agg(1,3)=a32der*xj
4073           agg(2,3)=a32der*yj
4074           agg(3,3)=a32der*zj
4075           agg(1,4)=a33der*xj
4076           agg(2,4)=a33der*yj
4077           agg(3,4)=a33der*zj
4078 ! Add the contributions coming from er
4079           fac3=-3.0d0*fac
4080           do k=1,3
4081             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4082             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4083             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4084             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4085           enddo
4086           do k=1,3
4087 ! Derivatives in DC(i)
4088 !grad            ghalf1=0.5d0*agg(k,1)
4089 !grad            ghalf2=0.5d0*agg(k,2)
4090 !grad            ghalf3=0.5d0*agg(k,3)
4091 !grad            ghalf4=0.5d0*agg(k,4)
4092             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4093             -3.0d0*uryg(k,2)*vry)!+ghalf1
4094             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4095             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4096             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4097             -3.0d0*urzg(k,2)*vry)!+ghalf3
4098             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4099             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4100 ! Derivatives in DC(i+1)
4101             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4102             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4103             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4104             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4105             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4106             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4107             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4108             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4109 ! Derivatives in DC(j)
4110             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4111             -3.0d0*vryg(k,2)*ury)!+ghalf1
4112             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4113             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4114             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4115             -3.0d0*vryg(k,2)*urz)!+ghalf3
4116             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4117             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4118 ! Derivatives in DC(j+1) or DC(nres-1)
4119             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4120             -3.0d0*vryg(k,3)*ury)
4121             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4122             -3.0d0*vrzg(k,3)*ury)
4123             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4124             -3.0d0*vryg(k,3)*urz)
4125             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4126             -3.0d0*vrzg(k,3)*urz)
4127 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4128 !grad              do l=1,4
4129 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4130 !grad              enddo
4131 !grad            endif
4132           enddo
4133           acipa(1,1)=a22
4134           acipa(1,2)=a23
4135           acipa(2,1)=a32
4136           acipa(2,2)=a33
4137           a22=-a22
4138           a23=-a23
4139           do l=1,2
4140             do k=1,3
4141               agg(k,l)=-agg(k,l)
4142               aggi(k,l)=-aggi(k,l)
4143               aggi1(k,l)=-aggi1(k,l)
4144               aggj(k,l)=-aggj(k,l)
4145               aggj1(k,l)=-aggj1(k,l)
4146             enddo
4147           enddo
4148           if (j.lt.nres-1) then
4149             a22=-a22
4150             a32=-a32
4151             do l=1,3,2
4152               do k=1,3
4153                 agg(k,l)=-agg(k,l)
4154                 aggi(k,l)=-aggi(k,l)
4155                 aggi1(k,l)=-aggi1(k,l)
4156                 aggj(k,l)=-aggj(k,l)
4157                 aggj1(k,l)=-aggj1(k,l)
4158               enddo
4159             enddo
4160           else
4161             a22=-a22
4162             a23=-a23
4163             a32=-a32
4164             a33=-a33
4165             do l=1,4
4166               do k=1,3
4167                 agg(k,l)=-agg(k,l)
4168                 aggi(k,l)=-aggi(k,l)
4169                 aggi1(k,l)=-aggi1(k,l)
4170                 aggj(k,l)=-aggj(k,l)
4171                 aggj1(k,l)=-aggj1(k,l)
4172               enddo
4173             enddo
4174           endif
4175           ENDIF ! WCORR
4176           IF (wel_loc.gt.0.0d0) THEN
4177 ! Contribution to the local-electrostatic energy coming from the i-j pair
4178           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4179            +a33*muij(4)
4180           if (shield_mode.eq.0) then
4181            fac_shield(i)=1.0
4182            fac_shield(j)=1.0
4183           endif
4184           eel_loc_ij=eel_loc_ij &
4185          *fac_shield(i)*fac_shield(j) &
4186          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4187 !C Now derivative over eel_loc
4188           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4189          (shield_mode.gt.0)) then
4190 !C          print *,i,j
4191
4192           do ilist=1,ishield_list(i)
4193            iresshield=shield_list(ilist,i)
4194            do k=1,3
4195            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4196                                                 /fac_shield(i)&
4197            *sss_ele_cut
4198            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4199                    rlocshield  &
4200           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4201           *sss_ele_cut
4202
4203             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4204            +rlocshield
4205            enddo
4206           enddo
4207           do ilist=1,ishield_list(j)
4208            iresshield=shield_list(ilist,j)
4209            do k=1,3
4210            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4211                                             /fac_shield(j)   &
4212             *sss_ele_cut
4213            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4214                    rlocshield  &
4215       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4216        *sss_ele_cut
4217
4218            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4219                   +rlocshield
4220
4221            enddo
4222           enddo
4223
4224           do k=1,3
4225             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4226                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4227                     *sss_ele_cut
4228             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4229                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4230                     *sss_ele_cut
4231             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4232                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4233                     *sss_ele_cut
4234             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4235                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4236                     *sss_ele_cut
4237
4238            enddo
4239            endif
4240
4241 #ifdef NEWCORR
4242          geel_loc_ij=(a22*gmuij1(1)&
4243           +a23*gmuij1(2)&
4244           +a32*gmuij1(3)&
4245           +a33*gmuij1(4))&
4246          *fac_shield(i)*fac_shield(j)&
4247                     *sss_ele_cut     &
4248          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4249
4250
4251 !c         write(iout,*) "derivative over thatai"
4252 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4253 !c     &   a33*gmuij1(4)
4254          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4255            geel_loc_ij*wel_loc
4256 !c         write(iout,*) "derivative over thatai-1"
4257 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4258 !c     &   a33*gmuij2(4)
4259          geel_loc_ij=&
4260           a22*gmuij2(1)&
4261           +a23*gmuij2(2)&
4262           +a32*gmuij2(3)&
4263           +a33*gmuij2(4)
4264          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4265            geel_loc_ij*wel_loc&
4266          *fac_shield(i)*fac_shield(j)&
4267                     *sss_ele_cut &
4268          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4269
4270
4271 !c  Derivative over j residue
4272          geel_loc_ji=a22*gmuji1(1)&
4273           +a23*gmuji1(2)&
4274           +a32*gmuji1(3)&
4275           +a33*gmuji1(4)
4276 !c         write(iout,*) "derivative over thataj"
4277 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4278 !c     &   a33*gmuji1(4)
4279
4280         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4281            geel_loc_ji*wel_loc&
4282          *fac_shield(i)*fac_shield(j)&
4283                     *sss_ele_cut &
4284          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4285
4286
4287          geel_loc_ji=&
4288           +a22*gmuji2(1)&
4289           +a23*gmuji2(2)&
4290           +a32*gmuji2(3)&
4291           +a33*gmuji2(4)
4292 !c         write(iout,*) "derivative over thataj-1"
4293 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4294 !c     &   a33*gmuji2(4)
4295          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4296            geel_loc_ji*wel_loc&
4297          *fac_shield(i)*fac_shield(j)&
4298                     *sss_ele_cut &
4299          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4300
4301 #endif
4302
4303 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4304 !           eel_loc_ij=0.0
4305 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4306 !                  'eelloc',i,j,eel_loc_ij
4307           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4308                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4309 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4310
4311 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4312 !          if (energy_dec) write (iout,*) "muij",muij
4313 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4314
4315           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4316 ! Partial derivatives in virtual-bond dihedral angles gamma
4317           if (i.gt.1) &
4318           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4319                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4320                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4321                  *sss_ele_cut  &
4322           *fac_shield(i)*fac_shield(j) &
4323           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4324
4325           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4326                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4327                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4328                  *sss_ele_cut &
4329           *fac_shield(i)*fac_shield(j) &
4330           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4331 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4332 !          do l=1,3
4333 !            ggg(1)=(agg(1,1)*muij(1)+ &
4334 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4335 !            *sss_ele_cut &
4336 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4337 !            ggg(2)=(agg(2,1)*muij(1)+ &
4338 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4339 !            *sss_ele_cut &
4340 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4341 !            ggg(3)=(agg(3,1)*muij(1)+ &
4342 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4343 !            *sss_ele_cut &
4344 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4345            xtemp(1)=xj
4346            xtemp(2)=yj
4347            xtemp(3)=zj
4348
4349            do l=1,3
4350             ggg(l)=(agg(l,1)*muij(1)+ &
4351                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4352             *sss_ele_cut &
4353           *fac_shield(i)*fac_shield(j) &
4354           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4355              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4356
4357
4358             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4359             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4360 !grad            ghalf=0.5d0*ggg(l)
4361 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4362 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4363           enddo
4364             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4365           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4366           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4367
4368             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4369           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4370           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4371
4372 !grad          do k=i+1,j2
4373 !grad            do l=1,3
4374 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4375 !grad            enddo
4376 !grad          enddo
4377 ! Remaining derivatives of eello
4378           do l=1,3
4379             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4380                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4381             *sss_ele_cut &
4382           *fac_shield(i)*fac_shield(j) &
4383           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4384
4385 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4386             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4387                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4388             +aggi1(l,4)*muij(4))&
4389             *sss_ele_cut &
4390           *fac_shield(i)*fac_shield(j) &
4391           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4392
4393 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4394             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4395                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4396             *sss_ele_cut &
4397           *fac_shield(i)*fac_shield(j) &
4398           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4399
4400 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4401             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4402                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4403             +aggj1(l,4)*muij(4))&
4404             *sss_ele_cut &
4405           *fac_shield(i)*fac_shield(j) &
4406          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4407
4408 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4409           enddo
4410           ENDIF
4411 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4412 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4413           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4414              .and. num_conti.le.maxconts) then
4415 !            write (iout,*) i,j," entered corr"
4416 !
4417 ! Calculate the contact function. The ith column of the array JCONT will
4418 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4419 ! greater than I). The arrays FACONT and GACONT will contain the values of
4420 ! the contact function and its derivative.
4421 !           r0ij=1.02D0*rpp(iteli,itelj)
4422 !           r0ij=1.11D0*rpp(iteli,itelj)
4423             r0ij=2.20D0*rpp(iteli,itelj)
4424 !           r0ij=1.55D0*rpp(iteli,itelj)
4425             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4426 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4427             if (fcont.gt.0.0D0) then
4428               num_conti=num_conti+1
4429               if (num_conti.gt.maxconts) then
4430 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4431 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4432                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4433                                ' will skip next contacts for this conf.', num_conti
4434               else
4435                 jcont_hb(num_conti,i)=j
4436 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4437 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4438                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4439                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4440 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4441 !  terms.
4442                 d_cont(num_conti,i)=rij
4443 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4444 !     --- Electrostatic-interaction matrix ---
4445                 a_chuj(1,1,num_conti,i)=a22
4446                 a_chuj(1,2,num_conti,i)=a23
4447                 a_chuj(2,1,num_conti,i)=a32
4448                 a_chuj(2,2,num_conti,i)=a33
4449 !     --- Gradient of rij
4450                 do kkk=1,3
4451                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4452                 enddo
4453                 kkll=0
4454                 do k=1,2
4455                   do l=1,2
4456                     kkll=kkll+1
4457                     do m=1,3
4458                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4459                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4460                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4461                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4462                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4463                     enddo
4464                   enddo
4465                 enddo
4466                 ENDIF
4467                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4468 ! Calculate contact energies
4469                 cosa4=4.0D0*cosa
4470                 wij=cosa-3.0D0*cosb*cosg
4471                 cosbg1=cosb+cosg
4472                 cosbg2=cosb-cosg
4473 !               fac3=dsqrt(-ael6i)/r0ij**3
4474                 fac3=dsqrt(-ael6i)*r3ij
4475 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4476                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4477                 if (ees0tmp.gt.0) then
4478                   ees0pij=dsqrt(ees0tmp)
4479                 else
4480                   ees0pij=0
4481                 endif
4482                 if (shield_mode.eq.0) then
4483                 fac_shield(i)=1.0d0
4484                 fac_shield(j)=1.0d0
4485                 else
4486                 ees0plist(num_conti,i)=j
4487                 endif
4488 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4489                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4490                 if (ees0tmp.gt.0) then
4491                   ees0mij=dsqrt(ees0tmp)
4492                 else
4493                   ees0mij=0
4494                 endif
4495 !               ees0mij=0.0D0
4496                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4497                      *sss_ele_cut &
4498                      *fac_shield(i)*fac_shield(j)
4499 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4500
4501                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4502                      *sss_ele_cut &
4503                      *fac_shield(i)*fac_shield(j)
4504 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4505
4506 ! Diagnostics. Comment out or remove after debugging!
4507 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4508 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4509 !               ees0m(num_conti,i)=0.0D0
4510 ! End diagnostics.
4511 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4512 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4513 ! Angular derivatives of the contact function
4514                 ees0pij1=fac3/ees0pij
4515                 ees0mij1=fac3/ees0mij
4516                 fac3p=-3.0D0*fac3*rrmij
4517                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4518                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4519 !               ees0mij1=0.0D0
4520                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4521                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4522                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4523                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4524                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4525                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4526                 ecosap=ecosa1+ecosa2
4527                 ecosbp=ecosb1+ecosb2
4528                 ecosgp=ecosg1+ecosg2
4529                 ecosam=ecosa1-ecosa2
4530                 ecosbm=ecosb1-ecosb2
4531                 ecosgm=ecosg1-ecosg2
4532 ! Diagnostics
4533 !               ecosap=ecosa1
4534 !               ecosbp=ecosb1
4535 !               ecosgp=ecosg1
4536 !               ecosam=0.0D0
4537 !               ecosbm=0.0D0
4538 !               ecosgm=0.0D0
4539 ! End diagnostics
4540                 facont_hb(num_conti,i)=fcont
4541                 fprimcont=fprimcont/rij
4542 !d              facont_hb(num_conti,i)=1.0D0
4543 ! Following line is for diagnostics.
4544 !d              fprimcont=0.0D0
4545                 do k=1,3
4546                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4547                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4548                 enddo
4549                 do k=1,3
4550                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4551                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4552                 enddo
4553                 gggp(1)=gggp(1)+ees0pijp*xj &
4554                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4555                 gggp(2)=gggp(2)+ees0pijp*yj &
4556                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4557                 gggp(3)=gggp(3)+ees0pijp*zj &
4558                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4559
4560                 gggm(1)=gggm(1)+ees0mijp*xj &
4561                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4562
4563                 gggm(2)=gggm(2)+ees0mijp*yj &
4564                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4565
4566                 gggm(3)=gggm(3)+ees0mijp*zj &
4567                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4568
4569 ! Derivatives due to the contact function
4570                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4571                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4572                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4573                 do k=1,3
4574 !
4575 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4576 !          following the change of gradient-summation algorithm.
4577 !
4578 !grad                  ghalfp=0.5D0*gggp(k)
4579 !grad                  ghalfm=0.5D0*gggm(k)
4580                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4581                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4582                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4583                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4584 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4585
4586
4587                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4588                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4589                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4590                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4591 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4592
4593
4594                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4595                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4596 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4597
4598                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4599                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4600                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4601                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4602 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4603
4604                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4605                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4606                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4607                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4608 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4609
4610                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4611                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4612 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4613
4614                 enddo
4615 ! Diagnostics. Comment out or remove after debugging!
4616 !diag           do k=1,3
4617 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4618 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4619 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4620 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4621 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4622 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4623 !diag           enddo
4624               ENDIF ! wcorr
4625               endif  ! num_conti.le.maxconts
4626             endif  ! fcont.gt.0
4627           endif    ! j.gt.i+1
4628           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4629             do k=1,4
4630               do l=1,3
4631                 ghalf=0.5d0*agg(l,k)
4632                 aggi(l,k)=aggi(l,k)+ghalf
4633                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4634                 aggj(l,k)=aggj(l,k)+ghalf
4635               enddo
4636             enddo
4637             if (j.eq.nres-1 .and. i.lt.j-2) then
4638               do k=1,4
4639                 do l=1,3
4640                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4641                 enddo
4642               enddo
4643             endif
4644           endif
4645  128  continue
4646 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4647       return
4648       end subroutine eelecij
4649 !-----------------------------------------------------------------------------
4650       subroutine eturn3(i,eello_turn3)
4651 ! Third- and fourth-order contributions from turns
4652
4653       use comm_locel
4654 !      implicit real*8 (a-h,o-z)
4655 !      include 'DIMENSIONS'
4656 !      include 'COMMON.IOUNITS'
4657 !      include 'COMMON.GEO'
4658 !      include 'COMMON.VAR'
4659 !      include 'COMMON.LOCAL'
4660 !      include 'COMMON.CHAIN'
4661 !      include 'COMMON.DERIV'
4662 !      include 'COMMON.INTERACT'
4663 !      include 'COMMON.CONTACTS'
4664 !      include 'COMMON.TORSION'
4665 !      include 'COMMON.VECTORS'
4666 !      include 'COMMON.FFIELD'
4667 !      include 'COMMON.CONTROL'
4668       real(kind=8),dimension(3) :: ggg
4669       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4670         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4671        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4672
4673       real(kind=8),dimension(2) :: auxvec,auxvec1
4674 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4675       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4676 !el      integer :: num_conti,j1,j2
4677 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4678 !el        dz_normi,xmedi,ymedi,zmedi
4679
4680 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4681 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4682 !el         num_conti,j1,j2
4683 !el local variables
4684       integer :: i,j,l,k,ilist,iresshield
4685       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4686
4687       j=i+2
4688 !      write (iout,*) "eturn3",i,j,j1,j2
4689           zj=(c(3,j)+c(3,j+1))/2.0d0
4690           zj=mod(zj,boxzsize)
4691           if (zj.lt.0) zj=zj+boxzsize
4692           if ((zj.lt.0)) write (*,*) "CHUJ"
4693        if ((zj.gt.bordlipbot)  &
4694         .and.(zj.lt.bordliptop)) then
4695 !C the energy transfer exist
4696         if (zj.lt.buflipbot) then
4697 !C what fraction I am in
4698          fracinbuf=1.0d0-     &
4699              ((zj-bordlipbot)/lipbufthick)
4700 !C lipbufthick is thickenes of lipid buffore
4701          sslipj=sscalelip(fracinbuf)
4702          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4703         elseif (zj.gt.bufliptop) then
4704          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4705          sslipj=sscalelip(fracinbuf)
4706          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4707         else
4708          sslipj=1.0d0
4709          ssgradlipj=0.0
4710         endif
4711        else
4712          sslipj=0.0d0
4713          ssgradlipj=0.0
4714        endif
4715
4716       a_temp(1,1)=a22
4717       a_temp(1,2)=a23
4718       a_temp(2,1)=a32
4719       a_temp(2,2)=a33
4720 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4721 !
4722 !               Third-order contributions
4723 !
4724 !                 (i+2)o----(i+3)
4725 !                      | |
4726 !                      | |
4727 !                 (i+1)o----i
4728 !
4729 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4730 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4731         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4732         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4733         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4734         call transpose2(auxmat(1,1),auxmat1(1,1))
4735         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4736         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4737         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4738         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4739         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4740
4741         if (shield_mode.eq.0) then
4742         fac_shield(i)=1.0d0
4743         fac_shield(j)=1.0d0
4744         endif
4745
4746         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4747          *fac_shield(i)*fac_shield(j)  &
4748          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4749         eello_t3= &
4750         0.5d0*(pizda(1,1)+pizda(2,2)) &
4751         *fac_shield(i)*fac_shield(j)
4752
4753         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4754                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4755 !C#ifdef NEWCORR
4756 !C Derivatives in theta
4757         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4758        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4759         *fac_shield(i)*fac_shield(j) &
4760         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4761
4762         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4763        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4764         *fac_shield(i)*fac_shield(j) &
4765         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4766
4767
4768 !C#endif
4769
4770
4771
4772           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4773        (shield_mode.gt.0)) then
4774 !C          print *,i,j
4775
4776           do ilist=1,ishield_list(i)
4777            iresshield=shield_list(ilist,i)
4778            do k=1,3
4779            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4780            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4781                    rlocshield &
4782            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4783             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4784              +rlocshield
4785            enddo
4786           enddo
4787           do ilist=1,ishield_list(j)
4788            iresshield=shield_list(ilist,j)
4789            do k=1,3
4790            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4791            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4792                    rlocshield &
4793            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4794            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4795                   +rlocshield
4796
4797            enddo
4798           enddo
4799
4800           do k=1,3
4801             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4802                    grad_shield(k,i)*eello_t3/fac_shield(i)
4803             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4804                    grad_shield(k,j)*eello_t3/fac_shield(j)
4805             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4806                    grad_shield(k,i)*eello_t3/fac_shield(i)
4807             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4808                    grad_shield(k,j)*eello_t3/fac_shield(j)
4809            enddo
4810            endif
4811
4812 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4813 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4814 !d     &    ' eello_turn3_num',4*eello_turn3_num
4815 ! Derivatives in gamma(i)
4816         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4817         call transpose2(auxmat2(1,1),auxmat3(1,1))
4818         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4819         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4820           *fac_shield(i)*fac_shield(j)        &
4821           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4822 ! Derivatives in gamma(i+1)
4823         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4824         call transpose2(auxmat2(1,1),auxmat3(1,1))
4825         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4826         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4827           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4828           *fac_shield(i)*fac_shield(j)        &
4829           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4830
4831 ! Cartesian derivatives
4832         do l=1,3
4833 !            ghalf1=0.5d0*agg(l,1)
4834 !            ghalf2=0.5d0*agg(l,2)
4835 !            ghalf3=0.5d0*agg(l,3)
4836 !            ghalf4=0.5d0*agg(l,4)
4837           a_temp(1,1)=aggi(l,1)!+ghalf1
4838           a_temp(1,2)=aggi(l,2)!+ghalf2
4839           a_temp(2,1)=aggi(l,3)!+ghalf3
4840           a_temp(2,2)=aggi(l,4)!+ghalf4
4841           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4842           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4843             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4844           *fac_shield(i)*fac_shield(j)      &
4845           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4846
4847           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4848           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4849           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4850           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4851           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4852           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4853             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4854           *fac_shield(i)*fac_shield(j)        &
4855           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4856
4857           a_temp(1,1)=aggj(l,1)!+ghalf1
4858           a_temp(1,2)=aggj(l,2)!+ghalf2
4859           a_temp(2,1)=aggj(l,3)!+ghalf3
4860           a_temp(2,2)=aggj(l,4)!+ghalf4
4861           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4862           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4863             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4864           *fac_shield(i)*fac_shield(j)      &
4865           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4866
4867           a_temp(1,1)=aggj1(l,1)
4868           a_temp(1,2)=aggj1(l,2)
4869           a_temp(2,1)=aggj1(l,3)
4870           a_temp(2,2)=aggj1(l,4)
4871           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4872           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4873             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4874           *fac_shield(i)*fac_shield(j)        &
4875           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4876         enddo
4877          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4878           ssgradlipi*eello_t3/4.0d0*lipscale
4879          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4880           ssgradlipj*eello_t3/4.0d0*lipscale
4881          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4882           ssgradlipi*eello_t3/4.0d0*lipscale
4883          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4884           ssgradlipj*eello_t3/4.0d0*lipscale
4885
4886       return
4887       end subroutine eturn3
4888 !-----------------------------------------------------------------------------
4889       subroutine eturn4(i,eello_turn4)
4890 ! Third- and fourth-order contributions from turns
4891
4892       use comm_locel
4893 !      implicit real*8 (a-h,o-z)
4894 !      include 'DIMENSIONS'
4895 !      include 'COMMON.IOUNITS'
4896 !      include 'COMMON.GEO'
4897 !      include 'COMMON.VAR'
4898 !      include 'COMMON.LOCAL'
4899 !      include 'COMMON.CHAIN'
4900 !      include 'COMMON.DERIV'
4901 !      include 'COMMON.INTERACT'
4902 !      include 'COMMON.CONTACTS'
4903 !      include 'COMMON.TORSION'
4904 !      include 'COMMON.VECTORS'
4905 !      include 'COMMON.FFIELD'
4906 !      include 'COMMON.CONTROL'
4907       real(kind=8),dimension(3) :: ggg
4908       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4909         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4910         gte1t,gte2t,gte3t,&
4911         gte1a,gtae3,gtae3e2, ae3gte2,&
4912         gtEpizda1,gtEpizda2,gtEpizda3
4913
4914       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4915        auxgEvec3,auxgvec
4916
4917 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4918       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4919 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4920 !el        dz_normi,xmedi,ymedi,zmedi
4921 !el      integer :: num_conti,j1,j2
4922 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4923 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4924 !el          num_conti,j1,j2
4925 !el local variables
4926       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4927       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4928          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
4929
4930       j=i+3
4931 !      if (j.ne.20) return
4932 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4933 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4934 !
4935 !               Fourth-order contributions
4936 !
4937 !                 (i+3)o----(i+4)
4938 !                     /  |
4939 !               (i+2)o   |
4940 !                     \  |
4941 !                 (i+1)o----i
4942 !
4943 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4944 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4945 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4946           zj=(c(3,j)+c(3,j+1))/2.0d0
4947           zj=mod(zj,boxzsize)
4948           if (zj.lt.0) zj=zj+boxzsize
4949        if ((zj.gt.bordlipbot)  &
4950         .and.(zj.lt.bordliptop)) then
4951 !C the energy transfer exist
4952         if (zj.lt.buflipbot) then
4953 !C what fraction I am in
4954          fracinbuf=1.0d0-     &
4955              ((zj-bordlipbot)/lipbufthick)
4956 !C lipbufthick is thickenes of lipid buffore
4957          sslipj=sscalelip(fracinbuf)
4958          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4959         elseif (zj.gt.bufliptop) then
4960          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4961          sslipj=sscalelip(fracinbuf)
4962          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4963         else
4964          sslipj=1.0d0
4965          ssgradlipj=0.0
4966         endif
4967        else
4968          sslipj=0.0d0
4969          ssgradlipj=0.0
4970        endif
4971
4972         a_temp(1,1)=a22
4973         a_temp(1,2)=a23
4974         a_temp(2,1)=a32
4975         a_temp(2,2)=a33
4976         iti1=i+1
4977         iti2=i+2
4978         iti3=i+3
4979 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4980         call transpose2(EUg(1,1,i+1),e1t(1,1))
4981         call transpose2(Eug(1,1,i+2),e2t(1,1))
4982         call transpose2(Eug(1,1,i+3),e3t(1,1))
4983 !C Ematrix derivative in theta
4984         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4985         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4986         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4987
4988         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4989         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4990         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4991         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4992 !c       auxalary matrix of E i+1
4993         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4994         s1=scalar2(b1(1,iti2),auxvec(1))
4995 !c derivative of theta i+2 with constant i+3
4996         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4997 !c derivative of theta i+2 with constant i+2
4998         gs32=scalar2(b1(1,i+2),auxgvec(1))
4999 !c derivative of E matix in theta of i+1
5000         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5001
5002         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5003         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5004         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5005 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5006         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5007 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5008         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5009         s2=scalar2(b1(1,i+1),auxvec(1))
5010 !c derivative of theta i+1 with constant i+3
5011         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5012 !c derivative of theta i+2 with constant i+1
5013         gs21=scalar2(b1(1,i+1),auxgvec(1))
5014 !c derivative of theta i+3 with constant i+1
5015         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5016
5017         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5018         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5019 !c ae3gte2 is derivative over i+2
5020         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5021
5022         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5023         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5024 !c i+2
5025         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5026 !c i+3
5027         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5028
5029         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5030         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5031         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5032         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5033         if (shield_mode.eq.0) then
5034         fac_shield(i)=1.0
5035         fac_shield(j)=1.0
5036         endif
5037
5038         eello_turn4=eello_turn4-(s1+s2+s3) &
5039         *fac_shield(i)*fac_shield(j)       &
5040         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5041         eello_t4=-(s1+s2+s3)  &
5042           *fac_shield(i)*fac_shield(j)
5043 !C Now derivative over shield:
5044           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5045          (shield_mode.gt.0)) then
5046 !C          print *,i,j
5047
5048           do ilist=1,ishield_list(i)
5049            iresshield=shield_list(ilist,i)
5050            do k=1,3
5051            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5052 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5053            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5054                    rlocshield &
5055             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5056             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5057            +rlocshield
5058            enddo
5059           enddo
5060           do ilist=1,ishield_list(j)
5061            iresshield=shield_list(ilist,j)
5062            do k=1,3
5063 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5064            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5065            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5066                    rlocshield  &
5067            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5068            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5069                   +rlocshield
5070 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5071
5072            enddo
5073           enddo
5074           do k=1,3
5075             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5076                    grad_shield(k,i)*eello_t4/fac_shield(i)
5077             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5078                    grad_shield(k,j)*eello_t4/fac_shield(j)
5079             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5080                    grad_shield(k,i)*eello_t4/fac_shield(i)
5081             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5082                    grad_shield(k,j)*eello_t4/fac_shield(j)
5083 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5084            enddo
5085            endif
5086 #ifdef NEWCORR
5087         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5088                        -(gs13+gsE13+gsEE1)*wturn4&
5089        *fac_shield(i)*fac_shield(j)
5090         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5091                          -(gs23+gs21+gsEE2)*wturn4&
5092        *fac_shield(i)*fac_shield(j)
5093
5094         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5095                          -(gs32+gsE31+gsEE3)*wturn4&
5096        *fac_shield(i)*fac_shield(j)
5097
5098 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5099 !c     &   gs2
5100 #endif
5101         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5102            'eturn4',i,j,-(s1+s2+s3)
5103 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5104 !d     &    ' eello_turn4_num',8*eello_turn4_num
5105 ! Derivatives in gamma(i)
5106         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5107         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5108         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5109         s1=scalar2(b1(1,i+1),auxvec(1))
5110         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5111         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5112         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5113        *fac_shield(i)*fac_shield(j)  &
5114        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5115
5116 ! Derivatives in gamma(i+1)
5117         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5118         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5119         s2=scalar2(b1(1,iti1),auxvec(1))
5120         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5121         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5122         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5123         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5124        *fac_shield(i)*fac_shield(j)  &
5125        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5126
5127 ! Derivatives in gamma(i+2)
5128         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5129         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5130         s1=scalar2(b1(1,iti2),auxvec(1))
5131         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5132         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5133         s2=scalar2(b1(1,iti1),auxvec(1))
5134         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5135         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5136         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5137         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5138        *fac_shield(i)*fac_shield(j)  &
5139        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5140
5141 ! Cartesian derivatives
5142 ! Derivatives of this turn contributions in DC(i+2)
5143         if (j.lt.nres-1) then
5144           do l=1,3
5145             a_temp(1,1)=agg(l,1)
5146             a_temp(1,2)=agg(l,2)
5147             a_temp(2,1)=agg(l,3)
5148             a_temp(2,2)=agg(l,4)
5149             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5150             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5151             s1=scalar2(b1(1,iti2),auxvec(1))
5152             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5153             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5154             s2=scalar2(b1(1,iti1),auxvec(1))
5155             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5156             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5157             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5158             ggg(l)=-(s1+s2+s3)
5159             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5160        *fac_shield(i)*fac_shield(j)  &
5161        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5162
5163           enddo
5164         endif
5165 ! Remaining derivatives of this turn contribution
5166         do l=1,3
5167           a_temp(1,1)=aggi(l,1)
5168           a_temp(1,2)=aggi(l,2)
5169           a_temp(2,1)=aggi(l,3)
5170           a_temp(2,2)=aggi(l,4)
5171           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5172           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5173           s1=scalar2(b1(1,iti2),auxvec(1))
5174           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5175           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5176           s2=scalar2(b1(1,iti1),auxvec(1))
5177           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5178           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5179           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5180           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5181          *fac_shield(i)*fac_shield(j)  &
5182          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5183
5184
5185           a_temp(1,1)=aggi1(l,1)
5186           a_temp(1,2)=aggi1(l,2)
5187           a_temp(2,1)=aggi1(l,3)
5188           a_temp(2,2)=aggi1(l,4)
5189           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5190           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5191           s1=scalar2(b1(1,iti2),auxvec(1))
5192           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5193           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5194           s2=scalar2(b1(1,iti1),auxvec(1))
5195           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5196           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5197           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5198           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5199          *fac_shield(i)*fac_shield(j)  &
5200          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5201
5202
5203           a_temp(1,1)=aggj(l,1)
5204           a_temp(1,2)=aggj(l,2)
5205           a_temp(2,1)=aggj(l,3)
5206           a_temp(2,2)=aggj(l,4)
5207           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5208           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5209           s1=scalar2(b1(1,iti2),auxvec(1))
5210           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5211           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5212           s2=scalar2(b1(1,iti1),auxvec(1))
5213           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5214           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5215           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5216 !        if (j.lt.nres-1) then
5217           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5218          *fac_shield(i)*fac_shield(j)  &
5219          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5220 !        endif
5221
5222           a_temp(1,1)=aggj1(l,1)
5223           a_temp(1,2)=aggj1(l,2)
5224           a_temp(2,1)=aggj1(l,3)
5225           a_temp(2,2)=aggj1(l,4)
5226           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5227           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5228           s1=scalar2(b1(1,iti2),auxvec(1))
5229           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5230           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5231           s2=scalar2(b1(1,iti1),auxvec(1))
5232           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5233           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5234           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5235 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5236 !        if (j.lt.nres-1) then
5237 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5238           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5239          *fac_shield(i)*fac_shield(j)  &
5240          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5241 !            if (shield_mode.gt.0) then
5242 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5243 !            else
5244 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5245 !            endif
5246 !         endif
5247         enddo
5248          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5249           ssgradlipi*eello_t4/4.0d0*lipscale
5250          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5251           ssgradlipj*eello_t4/4.0d0*lipscale
5252          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5253           ssgradlipi*eello_t4/4.0d0*lipscale
5254          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5255           ssgradlipj*eello_t4/4.0d0*lipscale
5256
5257       return
5258       end subroutine eturn4
5259 !-----------------------------------------------------------------------------
5260       subroutine unormderiv(u,ugrad,unorm,ungrad)
5261 ! This subroutine computes the derivatives of a normalized vector u, given
5262 ! the derivatives computed without normalization conditions, ugrad. Returns
5263 ! ungrad.
5264 !      implicit none
5265       real(kind=8),dimension(3) :: u,vec
5266       real(kind=8),dimension(3,3) ::ugrad,ungrad
5267       real(kind=8) :: unorm      !,scalar
5268       integer :: i,j
5269 !      write (2,*) 'ugrad',ugrad
5270 !      write (2,*) 'u',u
5271       do i=1,3
5272         vec(i)=scalar(ugrad(1,i),u(1))
5273       enddo
5274 !      write (2,*) 'vec',vec
5275       do i=1,3
5276         do j=1,3
5277           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5278         enddo
5279       enddo
5280 !      write (2,*) 'ungrad',ungrad
5281       return
5282       end subroutine unormderiv
5283 !-----------------------------------------------------------------------------
5284       subroutine escp_soft_sphere(evdw2,evdw2_14)
5285 !
5286 ! This subroutine calculates the excluded-volume interaction energy between
5287 ! peptide-group centers and side chains and its gradient in virtual-bond and
5288 ! side-chain vectors.
5289 !
5290 !      implicit real*8 (a-h,o-z)
5291 !      include 'DIMENSIONS'
5292 !      include 'COMMON.GEO'
5293 !      include 'COMMON.VAR'
5294 !      include 'COMMON.LOCAL'
5295 !      include 'COMMON.CHAIN'
5296 !      include 'COMMON.DERIV'
5297 !      include 'COMMON.INTERACT'
5298 !      include 'COMMON.FFIELD'
5299 !      include 'COMMON.IOUNITS'
5300 !      include 'COMMON.CONTROL'
5301       real(kind=8),dimension(3) :: ggg
5302 !el local variables
5303       integer :: i,iint,j,k,iteli,itypj
5304       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5305                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5306
5307       evdw2=0.0D0
5308       evdw2_14=0.0d0
5309       r0_scp=4.5d0
5310 !d    print '(a)','Enter ESCP'
5311 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5312       do i=iatscp_s,iatscp_e
5313         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5314         iteli=itel(i)
5315         xi=0.5D0*(c(1,i)+c(1,i+1))
5316         yi=0.5D0*(c(2,i)+c(2,i+1))
5317         zi=0.5D0*(c(3,i)+c(3,i+1))
5318           call to_box(xi,yi,zi)
5319
5320         do iint=1,nscp_gr(i)
5321
5322         do j=iscpstart(i,iint),iscpend(i,iint)
5323           if (itype(j,1).eq.ntyp1) cycle
5324           itypj=iabs(itype(j,1))
5325 ! Uncomment following three lines for SC-p interactions
5326 !         xj=c(1,nres+j)-xi
5327 !         yj=c(2,nres+j)-yi
5328 !         zj=c(3,nres+j)-zi
5329 ! Uncomment following three lines for Ca-p interactions
5330           xj=c(1,j)-xi
5331           yj=c(2,j)-yi
5332           zj=c(3,j)-zi
5333           call to_box(xj,yj,zj)
5334           xj=boxshift(xj-xi,boxxsize)
5335           yj=boxshift(yj-yi,boxysize)
5336           zj=boxshift(zj-zi,boxzsize)
5337           rij=xj*xj+yj*yj+zj*zj
5338           r0ij=r0_scp
5339           r0ijsq=r0ij*r0ij
5340           if (rij.lt.r0ijsq) then
5341             evdwij=0.25d0*(rij-r0ijsq)**2
5342             fac=rij-r0ijsq
5343           else
5344             evdwij=0.0d0
5345             fac=0.0d0
5346           endif
5347           evdw2=evdw2+evdwij
5348 !
5349 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5350 !
5351           ggg(1)=xj*fac
5352           ggg(2)=yj*fac
5353           ggg(3)=zj*fac
5354 !grad          if (j.lt.i) then
5355 !d          write (iout,*) 'j<i'
5356 ! Uncomment following three lines for SC-p interactions
5357 !           do k=1,3
5358 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5359 !           enddo
5360 !grad          else
5361 !d          write (iout,*) 'j>i'
5362 !grad            do k=1,3
5363 !grad              ggg(k)=-ggg(k)
5364 ! Uncomment following line for SC-p interactions
5365 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5366 !grad            enddo
5367 !grad          endif
5368 !grad          do k=1,3
5369 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5370 !grad          enddo
5371 !grad          kstart=min0(i+1,j)
5372 !grad          kend=max0(i-1,j-1)
5373 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5374 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5375 !grad          do k=kstart,kend
5376 !grad            do l=1,3
5377 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5378 !grad            enddo
5379 !grad          enddo
5380           do k=1,3
5381             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5382             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5383           enddo
5384         enddo
5385
5386         enddo ! iint
5387       enddo ! i
5388       return
5389       end subroutine escp_soft_sphere
5390 !-----------------------------------------------------------------------------
5391       subroutine escp(evdw2,evdw2_14)
5392 !
5393 ! This subroutine calculates the excluded-volume interaction energy between
5394 ! peptide-group centers and side chains and its gradient in virtual-bond and
5395 ! side-chain vectors.
5396 !
5397 !      implicit real*8 (a-h,o-z)
5398 !      include 'DIMENSIONS'
5399 !      include 'COMMON.GEO'
5400 !      include 'COMMON.VAR'
5401 !      include 'COMMON.LOCAL'
5402 !      include 'COMMON.CHAIN'
5403 !      include 'COMMON.DERIV'
5404 !      include 'COMMON.INTERACT'
5405 !      include 'COMMON.FFIELD'
5406 !      include 'COMMON.IOUNITS'
5407 !      include 'COMMON.CONTROL'
5408       real(kind=8),dimension(3) :: ggg
5409 !el local variables
5410       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5411       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5412                    e1,e2,evdwij,rij
5413       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5414                     dist_temp, dist_init
5415       integer xshift,yshift,zshift
5416
5417       evdw2=0.0D0
5418       evdw2_14=0.0d0
5419 !d    print '(a)','Enter ESCP'
5420 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5421 !      do i=iatscp_s,iatscp_e
5422        do icont=g_listscp_start,g_listscp_end
5423         i=newcontlistscpi(icont)
5424         j=newcontlistscpj(icont)
5425         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5426         iteli=itel(i)
5427         xi=0.5D0*(c(1,i)+c(1,i+1))
5428         yi=0.5D0*(c(2,i)+c(2,i+1))
5429         zi=0.5D0*(c(3,i)+c(3,i+1))
5430         call to_box(xi,yi,zi)
5431
5432 !        do iint=1,nscp_gr(i)
5433
5434 !        do j=iscpstart(i,iint),iscpend(i,iint)
5435           itypj=iabs(itype(j,1))
5436           if (itypj.eq.ntyp1) cycle
5437 ! Uncomment following three lines for SC-p interactions
5438 !         xj=c(1,nres+j)-xi
5439 !         yj=c(2,nres+j)-yi
5440 !         zj=c(3,nres+j)-zi
5441 ! Uncomment following three lines for Ca-p interactions
5442 !          xj=c(1,j)-xi
5443 !          yj=c(2,j)-yi
5444 !          zj=c(3,j)-zi
5445           xj=c(1,j)
5446           yj=c(2,j)
5447           zj=c(3,j)
5448           xj=mod(xj,boxxsize)
5449           if (xj.lt.0) xj=xj+boxxsize
5450           yj=mod(yj,boxysize)
5451           if (yj.lt.0) yj=yj+boxysize
5452           zj=mod(zj,boxzsize)
5453           if (zj.lt.0) zj=zj+boxzsize
5454
5455           call to_box(xj,yj,zj)
5456           xj=boxshift(xj-xi,boxxsize)
5457           yj=boxshift(yj-yi,boxysize)
5458           zj=boxshift(zj-zi,boxzsize)
5459
5460           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5461           rij=dsqrt(1.0d0/rrij)
5462             sss_ele_cut=sscale_ele(rij)
5463             sss_ele_grad=sscagrad_ele(rij)
5464 !            print *,sss_ele_cut,sss_ele_grad,&
5465 !            (rij),r_cut_ele,rlamb_ele
5466             if (sss_ele_cut.le.0.0) cycle
5467           fac=rrij**expon2
5468           e1=fac*fac*aad(itypj,iteli)
5469           e2=fac*bad(itypj,iteli)
5470           if (iabs(j-i) .le. 2) then
5471             e1=scal14*e1
5472             e2=scal14*e2
5473             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5474           endif
5475           evdwij=e1+e2
5476           evdw2=evdw2+evdwij*sss_ele_cut
5477 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5478 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5479           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5480              'evdw2',i,j,evdwij
5481 !
5482 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5483 !
5484           fac=-(evdwij+e1)*rrij*sss_ele_cut
5485           fac=fac+evdwij*sss_ele_grad/rij/expon
5486           ggg(1)=xj*fac
5487           ggg(2)=yj*fac
5488           ggg(3)=zj*fac
5489 !grad          if (j.lt.i) then
5490 !d          write (iout,*) 'j<i'
5491 ! Uncomment following three lines for SC-p interactions
5492 !           do k=1,3
5493 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5494 !           enddo
5495 !grad          else
5496 !d          write (iout,*) 'j>i'
5497 !grad            do k=1,3
5498 !grad              ggg(k)=-ggg(k)
5499 ! Uncomment following line for SC-p interactions
5500 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5501 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5502 !grad            enddo
5503 !grad          endif
5504 !grad          do k=1,3
5505 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5506 !grad          enddo
5507 !grad          kstart=min0(i+1,j)
5508 !grad          kend=max0(i-1,j-1)
5509 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5510 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5511 !grad          do k=kstart,kend
5512 !grad            do l=1,3
5513 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5514 !grad            enddo
5515 !grad          enddo
5516           do k=1,3
5517             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5518             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5519           enddo
5520 !        enddo
5521
5522 !        enddo ! iint
5523       enddo ! i
5524       do i=1,nct
5525         do j=1,3
5526           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5527           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5528           gradx_scp(j,i)=expon*gradx_scp(j,i)
5529         enddo
5530       enddo
5531 !******************************************************************************
5532 !
5533 !                              N O T E !!!
5534 !
5535 ! To save time the factor EXPON has been extracted from ALL components
5536 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5537 ! use!
5538 !
5539 !******************************************************************************
5540       return
5541       end subroutine escp
5542 !-----------------------------------------------------------------------------
5543       subroutine edis(ehpb)
5544 !
5545 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5546 !
5547 !      implicit real*8 (a-h,o-z)
5548 !      include 'DIMENSIONS'
5549 !      include 'COMMON.SBRIDGE'
5550 !      include 'COMMON.CHAIN'
5551 !      include 'COMMON.DERIV'
5552 !      include 'COMMON.VAR'
5553 !      include 'COMMON.INTERACT'
5554 !      include 'COMMON.IOUNITS'
5555       real(kind=8),dimension(3) :: ggg
5556 !el local variables
5557       integer :: i,j,ii,jj,iii,jjj,k
5558       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5559
5560       ehpb=0.0D0
5561 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5562 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5563       if (link_end.eq.0) return
5564       do i=link_start,link_end
5565 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5566 ! CA-CA distance used in regularization of structure.
5567         ii=ihpb(i)
5568         jj=jhpb(i)
5569 ! iii and jjj point to the residues for which the distance is assigned.
5570         if (ii.gt.nres) then
5571           iii=ii-nres
5572           jjj=jj-nres
5573         else
5574           iii=ii
5575           jjj=jj
5576         endif
5577 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5578 !     &    dhpb(i),dhpb1(i),forcon(i)
5579 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5580 !    distance and angle dependent SS bond potential.
5581 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5582 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5583         if (.not.dyn_ss .and. i.le.nss) then
5584 ! 15/02/13 CC dynamic SSbond - additional check
5585          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5586         iabs(itype(jjj,1)).eq.1) then
5587           call ssbond_ene(iii,jjj,eij)
5588           ehpb=ehpb+2*eij
5589 !d          write (iout,*) "eij",eij
5590          endif
5591         else if (ii.gt.nres .and. jj.gt.nres) then
5592 !c Restraints from contact prediction
5593           dd=dist(ii,jj)
5594           if (constr_dist.eq.11) then
5595             ehpb=ehpb+fordepth(i)**4.0d0 &
5596                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5597             fac=fordepth(i)**4.0d0 &
5598                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5599           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5600             ehpb,fordepth(i),dd
5601            else
5602           if (dhpb1(i).gt.0.0d0) then
5603             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5604             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5605 !c            write (iout,*) "beta nmr",
5606 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5607           else
5608             dd=dist(ii,jj)
5609             rdis=dd-dhpb(i)
5610 !C Get the force constant corresponding to this distance.
5611             waga=forcon(i)
5612 !C Calculate the contribution to energy.
5613             ehpb=ehpb+waga*rdis*rdis
5614 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5615 !C
5616 !C Evaluate gradient.
5617 !C
5618             fac=waga*rdis/dd
5619           endif
5620           endif
5621           do j=1,3
5622             ggg(j)=fac*(c(j,jj)-c(j,ii))
5623           enddo
5624           do j=1,3
5625             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5626             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5627           enddo
5628           do k=1,3
5629             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5630             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5631           enddo
5632         else
5633           dd=dist(ii,jj)
5634           if (constr_dist.eq.11) then
5635             ehpb=ehpb+fordepth(i)**4.0d0 &
5636                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5637             fac=fordepth(i)**4.0d0 &
5638                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5639           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5640          ehpb,fordepth(i),dd
5641            else
5642           if (dhpb1(i).gt.0.0d0) then
5643             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5644             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5645 !c            write (iout,*) "alph nmr",
5646 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5647           else
5648             rdis=dd-dhpb(i)
5649 !C Get the force constant corresponding to this distance.
5650             waga=forcon(i)
5651 !C Calculate the contribution to energy.
5652             ehpb=ehpb+waga*rdis*rdis
5653 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5654 !C
5655 !C Evaluate gradient.
5656 !C
5657             fac=waga*rdis/dd
5658           endif
5659           endif
5660
5661             do j=1,3
5662               ggg(j)=fac*(c(j,jj)-c(j,ii))
5663             enddo
5664 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5665 !C If this is a SC-SC distance, we need to calculate the contributions to the
5666 !C Cartesian gradient in the SC vectors (ghpbx).
5667           if (iii.lt.ii) then
5668           do j=1,3
5669             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5670             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5671           enddo
5672           endif
5673 !cgrad        do j=iii,jjj-1
5674 !cgrad          do k=1,3
5675 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5676 !cgrad          enddo
5677 !cgrad        enddo
5678           do k=1,3
5679             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5680             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5681           enddo
5682         endif
5683       enddo
5684       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5685
5686       return
5687       end subroutine edis
5688 !-----------------------------------------------------------------------------
5689       subroutine ssbond_ene(i,j,eij)
5690 !
5691 ! Calculate the distance and angle dependent SS-bond potential energy
5692 ! using a free-energy function derived based on RHF/6-31G** ab initio
5693 ! calculations of diethyl disulfide.
5694 !
5695 ! A. Liwo and U. Kozlowska, 11/24/03
5696 !
5697 !      implicit real*8 (a-h,o-z)
5698 !      include 'DIMENSIONS'
5699 !      include 'COMMON.SBRIDGE'
5700 !      include 'COMMON.CHAIN'
5701 !      include 'COMMON.DERIV'
5702 !      include 'COMMON.LOCAL'
5703 !      include 'COMMON.INTERACT'
5704 !      include 'COMMON.VAR'
5705 !      include 'COMMON.IOUNITS'
5706       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5707 !el local variables
5708       integer :: i,j,itypi,itypj,k
5709       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5710                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5711                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5712                    cosphi,ggk
5713
5714       itypi=iabs(itype(i,1))
5715       xi=c(1,nres+i)
5716       yi=c(2,nres+i)
5717       zi=c(3,nres+i)
5718       dxi=dc_norm(1,nres+i)
5719       dyi=dc_norm(2,nres+i)
5720       dzi=dc_norm(3,nres+i)
5721 !      dsci_inv=dsc_inv(itypi)
5722       dsci_inv=vbld_inv(nres+i)
5723       itypj=iabs(itype(j,1))
5724 !      dscj_inv=dsc_inv(itypj)
5725       dscj_inv=vbld_inv(nres+j)
5726       xj=c(1,nres+j)-xi
5727       yj=c(2,nres+j)-yi
5728       zj=c(3,nres+j)-zi
5729       dxj=dc_norm(1,nres+j)
5730       dyj=dc_norm(2,nres+j)
5731       dzj=dc_norm(3,nres+j)
5732       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5733       rij=dsqrt(rrij)
5734       erij(1)=xj*rij
5735       erij(2)=yj*rij
5736       erij(3)=zj*rij
5737       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5738       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5739       om12=dxi*dxj+dyi*dyj+dzi*dzj
5740       do k=1,3
5741         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5742         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5743       enddo
5744       rij=1.0d0/rij
5745       deltad=rij-d0cm
5746       deltat1=1.0d0-om1
5747       deltat2=1.0d0+om2
5748       deltat12=om2-om1+2.0d0
5749       cosphi=om12-om1*om2
5750       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5751         +akct*deltad*deltat12 &
5752         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5753 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5754 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5755 !     &  " deltat12",deltat12," eij",eij
5756       ed=2*akcm*deltad+akct*deltat12
5757       pom1=akct*deltad
5758       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5759       eom1=-2*akth*deltat1-pom1-om2*pom2
5760       eom2= 2*akth*deltat2+pom1-om1*pom2
5761       eom12=pom2
5762       do k=1,3
5763         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5764         ghpbx(k,i)=ghpbx(k,i)-ggk &
5765                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5766                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5767         ghpbx(k,j)=ghpbx(k,j)+ggk &
5768                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5769                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5770         ghpbc(k,i)=ghpbc(k,i)-ggk
5771         ghpbc(k,j)=ghpbc(k,j)+ggk
5772       enddo
5773 !
5774 ! Calculate the components of the gradient in DC and X
5775 !
5776 !grad      do k=i,j-1
5777 !grad        do l=1,3
5778 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5779 !grad        enddo
5780 !grad      enddo
5781       return
5782       end subroutine ssbond_ene
5783 !-----------------------------------------------------------------------------
5784       subroutine ebond(estr)
5785 !
5786 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5787 !
5788 !      implicit real*8 (a-h,o-z)
5789 !      include 'DIMENSIONS'
5790 !      include 'COMMON.LOCAL'
5791 !      include 'COMMON.GEO'
5792 !      include 'COMMON.INTERACT'
5793 !      include 'COMMON.DERIV'
5794 !      include 'COMMON.VAR'
5795 !      include 'COMMON.CHAIN'
5796 !      include 'COMMON.IOUNITS'
5797 !      include 'COMMON.NAMES'
5798 !      include 'COMMON.FFIELD'
5799 !      include 'COMMON.CONTROL'
5800 !      include 'COMMON.SETUP'
5801       real(kind=8),dimension(3) :: u,ud
5802 !el local variables
5803       integer :: i,j,iti,nbi,k
5804       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5805                    uprod1,uprod2
5806
5807       estr=0.0d0
5808       estr1=0.0d0
5809 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5810 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5811
5812       do i=ibondp_start,ibondp_end
5813         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5814         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5815 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5816 !C          do j=1,3
5817 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5818 !C            *dc(j,i-1)/vbld(i)
5819 !C          enddo
5820 !C          if (energy_dec) write(iout,*) &
5821 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5822         diff = vbld(i)-vbldpDUM
5823         else
5824         diff = vbld(i)-vbldp0
5825         endif
5826         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5827            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5828         estr=estr+diff*diff
5829         do j=1,3
5830           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5831         enddo
5832 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5833 !        endif
5834       enddo
5835       estr=0.5d0*AKP*estr+estr1
5836 !      print *,"estr_bb",estr,AKP
5837 !
5838 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5839 !
5840       do i=ibond_start,ibond_end
5841         iti=iabs(itype(i,1))
5842         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5843         if (iti.ne.10 .and. iti.ne.ntyp1) then
5844           nbi=nbondterm(iti)
5845           if (nbi.eq.1) then
5846             diff=vbld(i+nres)-vbldsc0(1,iti)
5847             if (energy_dec) write (iout,*) &
5848             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5849             AKSC(1,iti),AKSC(1,iti)*diff*diff
5850             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5851 !            print *,"estr_sc",estr
5852             do j=1,3
5853               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5854             enddo
5855           else
5856             do j=1,nbi
5857               diff=vbld(i+nres)-vbldsc0(j,iti)
5858               ud(j)=aksc(j,iti)*diff
5859               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5860             enddo
5861             uprod=u(1)
5862             do j=2,nbi
5863               uprod=uprod*u(j)
5864             enddo
5865             usum=0.0d0
5866             usumsqder=0.0d0
5867             do j=1,nbi
5868               uprod1=1.0d0
5869               uprod2=1.0d0
5870               do k=1,nbi
5871                 if (k.ne.j) then
5872                   uprod1=uprod1*u(k)
5873                   uprod2=uprod2*u(k)*u(k)
5874                 endif
5875               enddo
5876               usum=usum+uprod1
5877               usumsqder=usumsqder+ud(j)*uprod2
5878             enddo
5879             estr=estr+uprod/usum
5880 !            print *,"estr_sc",estr,i
5881
5882              if (energy_dec) write (iout,*) &
5883             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5884             AKSC(1,iti),uprod/usum
5885             do j=1,3
5886              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5887             enddo
5888           endif
5889         endif
5890       enddo
5891       return
5892       end subroutine ebond
5893 #ifdef CRYST_THETA
5894 !-----------------------------------------------------------------------------
5895       subroutine ebend(etheta)
5896 !
5897 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5898 ! angles gamma and its derivatives in consecutive thetas and gammas.
5899 !
5900       use comm_calcthet
5901 !      implicit real*8 (a-h,o-z)
5902 !      include 'DIMENSIONS'
5903 !      include 'COMMON.LOCAL'
5904 !      include 'COMMON.GEO'
5905 !      include 'COMMON.INTERACT'
5906 !      include 'COMMON.DERIV'
5907 !      include 'COMMON.VAR'
5908 !      include 'COMMON.CHAIN'
5909 !      include 'COMMON.IOUNITS'
5910 !      include 'COMMON.NAMES'
5911 !      include 'COMMON.FFIELD'
5912 !      include 'COMMON.CONTROL'
5913 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5914 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5915 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5916 !el      integer :: it
5917 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5918 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5919 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5920 !el local variables
5921       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5922        ichir21,ichir22
5923       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5924        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5925        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5926       real(kind=8),dimension(2) :: y,z
5927
5928       delta=0.02d0*pi
5929 !      time11=dexp(-2*time)
5930 !      time12=1.0d0
5931       etheta=0.0D0
5932 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5933       do i=ithet_start,ithet_end
5934         if (itype(i-1,1).eq.ntyp1) cycle
5935 ! Zero the energy function and its derivative at 0 or pi.
5936         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5937         it=itype(i-1,1)
5938         ichir1=isign(1,itype(i-2,1))
5939         ichir2=isign(1,itype(i,1))
5940          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5941          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5942          if (itype(i-1,1).eq.10) then
5943           itype1=isign(10,itype(i-2,1))
5944           ichir11=isign(1,itype(i-2,1))
5945           ichir12=isign(1,itype(i-2,1))
5946           itype2=isign(10,itype(i,1))
5947           ichir21=isign(1,itype(i,1))
5948           ichir22=isign(1,itype(i,1))
5949          endif
5950
5951         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5952 #ifdef OSF
5953           phii=phi(i)
5954           if (phii.ne.phii) phii=150.0
5955 #else
5956           phii=phi(i)
5957 #endif
5958           y(1)=dcos(phii)
5959           y(2)=dsin(phii)
5960         else
5961           y(1)=0.0D0
5962           y(2)=0.0D0
5963         endif
5964         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5965 #ifdef OSF
5966           phii1=phi(i+1)
5967           if (phii1.ne.phii1) phii1=150.0
5968           phii1=pinorm(phii1)
5969           z(1)=cos(phii1)
5970 #else
5971           phii1=phi(i+1)
5972           z(1)=dcos(phii1)
5973 #endif
5974           z(2)=dsin(phii1)
5975         else
5976           z(1)=0.0D0
5977           z(2)=0.0D0
5978         endif
5979 ! Calculate the "mean" value of theta from the part of the distribution
5980 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5981 ! In following comments this theta will be referred to as t_c.
5982         thet_pred_mean=0.0d0
5983         do k=1,2
5984             athetk=athet(k,it,ichir1,ichir2)
5985             bthetk=bthet(k,it,ichir1,ichir2)
5986           if (it.eq.10) then
5987              athetk=athet(k,itype1,ichir11,ichir12)
5988              bthetk=bthet(k,itype2,ichir21,ichir22)
5989           endif
5990          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5991         enddo
5992         dthett=thet_pred_mean*ssd
5993         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5994 ! Derivatives of the "mean" values in gamma1 and gamma2.
5995         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5996                +athet(2,it,ichir1,ichir2)*y(1))*ss
5997         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5998                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5999          if (it.eq.10) then
6000         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6001              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6002         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6003                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6004          endif
6005         if (theta(i).gt.pi-delta) then
6006           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6007                E_tc0)
6008           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6009           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6010           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6011               E_theta)
6012           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6013               E_tc)
6014         else if (theta(i).lt.delta) then
6015           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6016           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6017           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6018               E_theta)
6019           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6020           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6021               E_tc)
6022         else
6023           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6024               E_theta,E_tc)
6025         endif
6026         etheta=etheta+ethetai
6027         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6028             'ebend',i,ethetai
6029         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6030         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6031         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6032       enddo
6033 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6034
6035 ! Ufff.... We've done all this!!!
6036       return
6037       end subroutine ebend
6038 !-----------------------------------------------------------------------------
6039       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6040
6041       use comm_calcthet
6042 !      implicit real*8 (a-h,o-z)
6043 !      include 'DIMENSIONS'
6044 !      include 'COMMON.LOCAL'
6045 !      include 'COMMON.IOUNITS'
6046 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6047 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6048 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6049       integer :: i,j,k
6050       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6051 !el      integer :: it
6052 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6053 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6054 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6055 !el local variables
6056       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6057        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6058
6059 ! Calculate the contributions to both Gaussian lobes.
6060 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6061 ! The "polynomial part" of the "standard deviation" of this part of
6062 ! the distribution.
6063         sig=polthet(3,it)
6064         do j=2,0,-1
6065           sig=sig*thet_pred_mean+polthet(j,it)
6066         enddo
6067 ! Derivative of the "interior part" of the "standard deviation of the"
6068 ! gamma-dependent Gaussian lobe in t_c.
6069         sigtc=3*polthet(3,it)
6070         do j=2,1,-1
6071           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6072         enddo
6073         sigtc=sig*sigtc
6074 ! Set the parameters of both Gaussian lobes of the distribution.
6075 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6076         fac=sig*sig+sigc0(it)
6077         sigcsq=fac+fac
6078         sigc=1.0D0/sigcsq
6079 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6080         sigsqtc=-4.0D0*sigcsq*sigtc
6081 !       print *,i,sig,sigtc,sigsqtc
6082 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6083         sigtc=-sigtc/(fac*fac)
6084 ! Following variable is sigma(t_c)**(-2)
6085         sigcsq=sigcsq*sigcsq
6086         sig0i=sig0(it)
6087         sig0inv=1.0D0/sig0i**2
6088         delthec=thetai-thet_pred_mean
6089         delthe0=thetai-theta0i
6090         term1=-0.5D0*sigcsq*delthec*delthec
6091         term2=-0.5D0*sig0inv*delthe0*delthe0
6092 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6093 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6094 ! to the energy (this being the log of the distribution) at the end of energy
6095 ! term evaluation for this virtual-bond angle.
6096         if (term1.gt.term2) then
6097           termm=term1
6098           term2=dexp(term2-termm)
6099           term1=1.0d0
6100         else
6101           termm=term2
6102           term1=dexp(term1-termm)
6103           term2=1.0d0
6104         endif
6105 ! The ratio between the gamma-independent and gamma-dependent lobes of
6106 ! the distribution is a Gaussian function of thet_pred_mean too.
6107         diffak=gthet(2,it)-thet_pred_mean
6108         ratak=diffak/gthet(3,it)**2
6109         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6110 ! Let's differentiate it in thet_pred_mean NOW.
6111         aktc=ak*ratak
6112 ! Now put together the distribution terms to make complete distribution.
6113         termexp=term1+ak*term2
6114         termpre=sigc+ak*sig0i
6115 ! Contribution of the bending energy from this theta is just the -log of
6116 ! the sum of the contributions from the two lobes and the pre-exponential
6117 ! factor. Simple enough, isn't it?
6118         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6119 ! NOW the derivatives!!!
6120 ! 6/6/97 Take into account the deformation.
6121         E_theta=(delthec*sigcsq*term1 &
6122              +ak*delthe0*sig0inv*term2)/termexp
6123         E_tc=((sigtc+aktc*sig0i)/termpre &
6124             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6125              aktc*term2)/termexp)
6126       return
6127       end subroutine theteng
6128 #else
6129 !-----------------------------------------------------------------------------
6130       subroutine ebend(etheta)
6131 !
6132 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6133 ! angles gamma and its derivatives in consecutive thetas and gammas.
6134 ! ab initio-derived potentials from
6135 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6136 !
6137 !      implicit real*8 (a-h,o-z)
6138 !      include 'DIMENSIONS'
6139 !      include 'COMMON.LOCAL'
6140 !      include 'COMMON.GEO'
6141 !      include 'COMMON.INTERACT'
6142 !      include 'COMMON.DERIV'
6143 !      include 'COMMON.VAR'
6144 !      include 'COMMON.CHAIN'
6145 !      include 'COMMON.IOUNITS'
6146 !      include 'COMMON.NAMES'
6147 !      include 'COMMON.FFIELD'
6148 !      include 'COMMON.CONTROL'
6149       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6150       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6151       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6152       logical :: lprn=.false., lprn1=.false.
6153 !el local variables
6154       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6155       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6156       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6157 ! local variables for constrains
6158       real(kind=8) :: difi,thetiii
6159        integer itheta
6160 !      write(iout,*) "in ebend",ithet_start,ithet_end
6161       call flush(iout)
6162       etheta=0.0D0
6163       do i=ithet_start,ithet_end
6164         if (itype(i-1,1).eq.ntyp1) cycle
6165         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6166         if (iabs(itype(i+1,1)).eq.20) iblock=2
6167         if (iabs(itype(i+1,1)).ne.20) iblock=1
6168         dethetai=0.0d0
6169         dephii=0.0d0
6170         dephii1=0.0d0
6171         theti2=0.5d0*theta(i)
6172         ityp2=ithetyp((itype(i-1,1)))
6173         do k=1,nntheterm
6174           coskt(k)=dcos(k*theti2)
6175           sinkt(k)=dsin(k*theti2)
6176         enddo
6177         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6178 #ifdef OSF
6179           phii=phi(i)
6180           if (phii.ne.phii) phii=150.0
6181 #else
6182           phii=phi(i)
6183 #endif
6184           ityp1=ithetyp((itype(i-2,1)))
6185 ! propagation of chirality for glycine type
6186           do k=1,nsingle
6187             cosph1(k)=dcos(k*phii)
6188             sinph1(k)=dsin(k*phii)
6189           enddo
6190         else
6191           phii=0.0d0
6192           ityp1=ithetyp(itype(i-2,1))
6193           do k=1,nsingle
6194             cosph1(k)=0.0d0
6195             sinph1(k)=0.0d0
6196           enddo
6197         endif
6198         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6199 #ifdef OSF
6200           phii1=phi(i+1)
6201           if (phii1.ne.phii1) phii1=150.0
6202           phii1=pinorm(phii1)
6203 #else
6204           phii1=phi(i+1)
6205 #endif
6206           ityp3=ithetyp((itype(i,1)))
6207           do k=1,nsingle
6208             cosph2(k)=dcos(k*phii1)
6209             sinph2(k)=dsin(k*phii1)
6210           enddo
6211         else
6212           phii1=0.0d0
6213           ityp3=ithetyp(itype(i,1))
6214           do k=1,nsingle
6215             cosph2(k)=0.0d0
6216             sinph2(k)=0.0d0
6217           enddo
6218         endif
6219         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6220         do k=1,ndouble
6221           do l=1,k-1
6222             ccl=cosph1(l)*cosph2(k-l)
6223             ssl=sinph1(l)*sinph2(k-l)
6224             scl=sinph1(l)*cosph2(k-l)
6225             csl=cosph1(l)*sinph2(k-l)
6226             cosph1ph2(l,k)=ccl-ssl
6227             cosph1ph2(k,l)=ccl+ssl
6228             sinph1ph2(l,k)=scl+csl
6229             sinph1ph2(k,l)=scl-csl
6230           enddo
6231         enddo
6232         if (lprn) then
6233         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6234           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6235         write (iout,*) "coskt and sinkt"
6236         do k=1,nntheterm
6237           write (iout,*) k,coskt(k),sinkt(k)
6238         enddo
6239         endif
6240         do k=1,ntheterm
6241           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6242           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6243             *coskt(k)
6244           if (lprn) &
6245           write (iout,*) "k",k,&
6246            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6247            " ethetai",ethetai
6248         enddo
6249         if (lprn) then
6250         write (iout,*) "cosph and sinph"
6251         do k=1,nsingle
6252           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6253         enddo
6254         write (iout,*) "cosph1ph2 and sinph2ph2"
6255         do k=2,ndouble
6256           do l=1,k-1
6257             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6258                sinph1ph2(l,k),sinph1ph2(k,l)
6259           enddo
6260         enddo
6261         write(iout,*) "ethetai",ethetai
6262         endif
6263         do m=1,ntheterm2
6264           do k=1,nsingle
6265             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6266                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6267                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6268                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6269             ethetai=ethetai+sinkt(m)*aux
6270             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6271             dephii=dephii+k*sinkt(m)* &
6272                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6273                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6274             dephii1=dephii1+k*sinkt(m)* &
6275                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6276                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6277             if (lprn) &
6278             write (iout,*) "m",m," k",k," bbthet", &
6279                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6280                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6281                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6282                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6283           enddo
6284         enddo
6285         if (lprn) &
6286         write(iout,*) "ethetai",ethetai
6287         do m=1,ntheterm3
6288           do k=2,ndouble
6289             do l=1,k-1
6290               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6291                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6292                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6293                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6294               ethetai=ethetai+sinkt(m)*aux
6295               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6296               dephii=dephii+l*sinkt(m)* &
6297                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6298                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6299                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6300                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6301               dephii1=dephii1+(k-l)*sinkt(m)* &
6302                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6303                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6304                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6305                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6306               if (lprn) then
6307               write (iout,*) "m",m," k",k," l",l," ffthet",&
6308                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6309                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6310                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6311                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6312                   " ethetai",ethetai
6313               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6314                   cosph1ph2(k,l)*sinkt(m),&
6315                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6316               endif
6317             enddo
6318           enddo
6319         enddo
6320 10      continue
6321 !        lprn1=.true.
6322         if (lprn1) &
6323           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6324          i,theta(i)*rad2deg,phii*rad2deg,&
6325          phii1*rad2deg,ethetai
6326 !        lprn1=.false.
6327         etheta=etheta+ethetai
6328         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6329                                     'ebend',i,ethetai
6330         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6331         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6332         gloc(nphi+i-2,icg)=wang*dethetai
6333       enddo
6334 !-----------thete constrains
6335 !      if (tor_mode.ne.2) then
6336
6337       return
6338       end subroutine ebend
6339 #endif
6340 #ifdef CRYST_SC
6341 !-----------------------------------------------------------------------------
6342       subroutine esc(escloc)
6343 ! Calculate the local energy of a side chain and its derivatives in the
6344 ! corresponding virtual-bond valence angles THETA and the spherical angles
6345 ! ALPHA and OMEGA.
6346 !
6347       use comm_sccalc
6348 !      implicit real*8 (a-h,o-z)
6349 !      include 'DIMENSIONS'
6350 !      include 'COMMON.GEO'
6351 !      include 'COMMON.LOCAL'
6352 !      include 'COMMON.VAR'
6353 !      include 'COMMON.INTERACT'
6354 !      include 'COMMON.DERIV'
6355 !      include 'COMMON.CHAIN'
6356 !      include 'COMMON.IOUNITS'
6357 !      include 'COMMON.NAMES'
6358 !      include 'COMMON.FFIELD'
6359 !      include 'COMMON.CONTROL'
6360       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6361          ddersc0,ddummy,xtemp,temp
6362 !el      real(kind=8) :: time11,time12,time112,theti
6363       real(kind=8) :: escloc,delta
6364 !el      integer :: it,nlobit
6365 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6366 !el local variables
6367       integer :: i,k
6368       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6369        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6370       delta=0.02d0*pi
6371       escloc=0.0D0
6372 !     write (iout,'(a)') 'ESC'
6373       do i=loc_start,loc_end
6374         it=itype(i,1)
6375         if (it.eq.ntyp1) cycle
6376         if (it.eq.10) goto 1
6377         nlobit=nlob(iabs(it))
6378 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6379 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6380         theti=theta(i+1)-pipol
6381         x(1)=dtan(theti)
6382         x(2)=alph(i)
6383         x(3)=omeg(i)
6384
6385         if (x(2).gt.pi-delta) then
6386           xtemp(1)=x(1)
6387           xtemp(2)=pi-delta
6388           xtemp(3)=x(3)
6389           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6390           xtemp(2)=pi
6391           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6392           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6393               escloci,dersc(2))
6394           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6395               ddersc0(1),dersc(1))
6396           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6397               ddersc0(3),dersc(3))
6398           xtemp(2)=pi-delta
6399           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6400           xtemp(2)=pi
6401           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6402           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6403                   dersc0(2),esclocbi,dersc02)
6404           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6405                   dersc12,dersc01)
6406           call splinthet(x(2),0.5d0*delta,ss,ssd)
6407           dersc0(1)=dersc01
6408           dersc0(2)=dersc02
6409           dersc0(3)=0.0d0
6410           do k=1,3
6411             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6412           enddo
6413           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6414 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6415 !    &             esclocbi,ss,ssd
6416           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6417 !         escloci=esclocbi
6418 !         write (iout,*) escloci
6419         else if (x(2).lt.delta) then
6420           xtemp(1)=x(1)
6421           xtemp(2)=delta
6422           xtemp(3)=x(3)
6423           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6424           xtemp(2)=0.0d0
6425           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6426           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6427               escloci,dersc(2))
6428           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6429               ddersc0(1),dersc(1))
6430           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6431               ddersc0(3),dersc(3))
6432           xtemp(2)=delta
6433           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6434           xtemp(2)=0.0d0
6435           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6436           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6437                   dersc0(2),esclocbi,dersc02)
6438           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6439                   dersc12,dersc01)
6440           dersc0(1)=dersc01
6441           dersc0(2)=dersc02
6442           dersc0(3)=0.0d0
6443           call splinthet(x(2),0.5d0*delta,ss,ssd)
6444           do k=1,3
6445             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6446           enddo
6447           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6448 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6449 !    &             esclocbi,ss,ssd
6450           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6451 !         write (iout,*) escloci
6452         else
6453           call enesc(x,escloci,dersc,ddummy,.false.)
6454         endif
6455
6456         escloc=escloc+escloci
6457         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6458            'escloc',i,escloci
6459 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6460
6461         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6462          wscloc*dersc(1)
6463         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6464         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6465     1   continue
6466       enddo
6467       return
6468       end subroutine esc
6469 !-----------------------------------------------------------------------------
6470       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6471
6472       use comm_sccalc
6473 !      implicit real*8 (a-h,o-z)
6474 !      include 'DIMENSIONS'
6475 !      include 'COMMON.GEO'
6476 !      include 'COMMON.LOCAL'
6477 !      include 'COMMON.IOUNITS'
6478 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6479       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6480       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6481       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6482       real(kind=8) :: escloci
6483       logical :: mixed
6484 !el local variables
6485       integer :: j,iii,l,k !el,it,nlobit
6486       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6487 !el       time11,time12,time112
6488 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6489         escloc_i=0.0D0
6490         do j=1,3
6491           dersc(j)=0.0D0
6492           if (mixed) ddersc(j)=0.0d0
6493         enddo
6494         x3=x(3)
6495
6496 ! Because of periodicity of the dependence of the SC energy in omega we have
6497 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6498 ! To avoid underflows, first compute & store the exponents.
6499
6500         do iii=-1,1
6501
6502           x(3)=x3+iii*dwapi
6503
6504           do j=1,nlobit
6505             do k=1,3
6506               z(k)=x(k)-censc(k,j,it)
6507             enddo
6508             do k=1,3
6509               Axk=0.0D0
6510               do l=1,3
6511                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6512               enddo
6513               Ax(k,j,iii)=Axk
6514             enddo
6515             expfac=0.0D0
6516             do k=1,3
6517               expfac=expfac+Ax(k,j,iii)*z(k)
6518             enddo
6519             contr(j,iii)=expfac
6520           enddo ! j
6521
6522         enddo ! iii
6523
6524         x(3)=x3
6525 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6526 ! subsequent NaNs and INFs in energy calculation.
6527 ! Find the largest exponent
6528         emin=contr(1,-1)
6529         do iii=-1,1
6530           do j=1,nlobit
6531             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6532           enddo
6533         enddo
6534         emin=0.5D0*emin
6535 !d      print *,'it=',it,' emin=',emin
6536
6537 ! Compute the contribution to SC energy and derivatives
6538         do iii=-1,1
6539
6540           do j=1,nlobit
6541 #ifdef OSF
6542             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6543             if(adexp.ne.adexp) adexp=1.0
6544             expfac=dexp(adexp)
6545 #else
6546             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6547 #endif
6548 !d          print *,'j=',j,' expfac=',expfac
6549             escloc_i=escloc_i+expfac
6550             do k=1,3
6551               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6552             enddo
6553             if (mixed) then
6554               do k=1,3,2
6555                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6556                   +gaussc(k,2,j,it))*expfac
6557               enddo
6558             endif
6559           enddo
6560
6561         enddo ! iii
6562
6563         dersc(1)=dersc(1)/cos(theti)**2
6564         ddersc(1)=ddersc(1)/cos(theti)**2
6565         ddersc(3)=ddersc(3)
6566
6567         escloci=-(dlog(escloc_i)-emin)
6568         do j=1,3
6569           dersc(j)=dersc(j)/escloc_i
6570         enddo
6571         if (mixed) then
6572           do j=1,3,2
6573             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6574           enddo
6575         endif
6576       return
6577       end subroutine enesc
6578 !-----------------------------------------------------------------------------
6579       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6580
6581       use comm_sccalc
6582 !      implicit real*8 (a-h,o-z)
6583 !      include 'DIMENSIONS'
6584 !      include 'COMMON.GEO'
6585 !      include 'COMMON.LOCAL'
6586 !      include 'COMMON.IOUNITS'
6587 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6588       real(kind=8),dimension(3) :: x,z,dersc
6589       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6590       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6591       real(kind=8) :: escloci,dersc12,emin
6592       logical :: mixed
6593 !el local varables
6594       integer :: j,k,l !el,it,nlobit
6595       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6596
6597       escloc_i=0.0D0
6598
6599       do j=1,3
6600         dersc(j)=0.0D0
6601       enddo
6602
6603       do j=1,nlobit
6604         do k=1,2
6605           z(k)=x(k)-censc(k,j,it)
6606         enddo
6607         z(3)=dwapi
6608         do k=1,3
6609           Axk=0.0D0
6610           do l=1,3
6611             Axk=Axk+gaussc(l,k,j,it)*z(l)
6612           enddo
6613           Ax(k,j)=Axk
6614         enddo
6615         expfac=0.0D0
6616         do k=1,3
6617           expfac=expfac+Ax(k,j)*z(k)
6618         enddo
6619         contr(j)=expfac
6620       enddo ! j
6621
6622 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6623 ! subsequent NaNs and INFs in energy calculation.
6624 ! Find the largest exponent
6625       emin=contr(1)
6626       do j=1,nlobit
6627         if (emin.gt.contr(j)) emin=contr(j)
6628       enddo
6629       emin=0.5D0*emin
6630
6631 ! Compute the contribution to SC energy and derivatives
6632
6633       dersc12=0.0d0
6634       do j=1,nlobit
6635         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6636         escloc_i=escloc_i+expfac
6637         do k=1,2
6638           dersc(k)=dersc(k)+Ax(k,j)*expfac
6639         enddo
6640         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6641                   +gaussc(1,2,j,it))*expfac
6642         dersc(3)=0.0d0
6643       enddo
6644
6645       dersc(1)=dersc(1)/cos(theti)**2
6646       dersc12=dersc12/cos(theti)**2
6647       escloci=-(dlog(escloc_i)-emin)
6648       do j=1,2
6649         dersc(j)=dersc(j)/escloc_i
6650       enddo
6651       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6652       return
6653       end subroutine enesc_bound
6654 #else
6655 !-----------------------------------------------------------------------------
6656       subroutine esc(escloc)
6657 ! Calculate the local energy of a side chain and its derivatives in the
6658 ! corresponding virtual-bond valence angles THETA and the spherical angles
6659 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6660 ! added by Urszula Kozlowska. 07/11/2007
6661 !
6662       use comm_sccalc
6663 !      implicit real*8 (a-h,o-z)
6664 !      include 'DIMENSIONS'
6665 !      include 'COMMON.GEO'
6666 !      include 'COMMON.LOCAL'
6667 !      include 'COMMON.VAR'
6668 !      include 'COMMON.SCROT'
6669 !      include 'COMMON.INTERACT'
6670 !      include 'COMMON.DERIV'
6671 !      include 'COMMON.CHAIN'
6672 !      include 'COMMON.IOUNITS'
6673 !      include 'COMMON.NAMES'
6674 !      include 'COMMON.FFIELD'
6675 !      include 'COMMON.CONTROL'
6676 !      include 'COMMON.VECTORS'
6677       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6678       real(kind=8),dimension(65) :: x
6679       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6680          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6681       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6682       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6683          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6684 !el local variables
6685       integer :: i,j,k !el,it,nlobit
6686       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6687 !el      real(kind=8) :: time11,time12,time112,theti
6688 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6689       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6690                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6691                    sumene1x,sumene2x,sumene3x,sumene4x,&
6692                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6693                    cosfac2xx,sinfac2yy
6694 #ifdef DEBUG
6695       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6696                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6697                    de_dt_num
6698 #endif
6699 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6700
6701       delta=0.02d0*pi
6702       escloc=0.0D0
6703       do i=loc_start,loc_end
6704         if (itype(i,1).eq.ntyp1) cycle
6705         costtab(i+1) =dcos(theta(i+1))
6706         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6707         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6708         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6709         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6710         cosfac=dsqrt(cosfac2)
6711         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6712         sinfac=dsqrt(sinfac2)
6713         it=iabs(itype(i,1))
6714         if (it.eq.10) goto 1
6715 !
6716 !  Compute the axes of tghe local cartesian coordinates system; store in
6717 !   x_prime, y_prime and z_prime
6718 !
6719         do j=1,3
6720           x_prime(j) = 0.00
6721           y_prime(j) = 0.00
6722           z_prime(j) = 0.00
6723         enddo
6724 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6725 !     &   dc_norm(3,i+nres)
6726         do j = 1,3
6727           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6728           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6729         enddo
6730         do j = 1,3
6731           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6732         enddo
6733 !       write (2,*) "i",i
6734 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6735 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6736 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6737 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6738 !      & " xy",scalar(x_prime(1),y_prime(1)),
6739 !      & " xz",scalar(x_prime(1),z_prime(1)),
6740 !      & " yy",scalar(y_prime(1),y_prime(1)),
6741 !      & " yz",scalar(y_prime(1),z_prime(1)),
6742 !      & " zz",scalar(z_prime(1),z_prime(1))
6743 !
6744 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6745 ! to local coordinate system. Store in xx, yy, zz.
6746 !
6747         xx=0.0d0
6748         yy=0.0d0
6749         zz=0.0d0
6750         do j = 1,3
6751           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6752           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6753           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6754         enddo
6755
6756         xxtab(i)=xx
6757         yytab(i)=yy
6758         zztab(i)=zz
6759 !
6760 ! Compute the energy of the ith side cbain
6761 !
6762 !        write (2,*) "xx",xx," yy",yy," zz",zz
6763         it=iabs(itype(i,1))
6764         do j = 1,65
6765           x(j) = sc_parmin(j,it)
6766         enddo
6767 #ifdef CHECK_COORD
6768 !c diagnostics - remove later
6769         xx1 = dcos(alph(2))
6770         yy1 = dsin(alph(2))*dcos(omeg(2))
6771         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6772         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6773           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6774           xx1,yy1,zz1
6775 !,"  --- ", xx_w,yy_w,zz_w
6776 ! end diagnostics
6777 #endif
6778         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6779          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6780          + x(10)*yy*zz
6781         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6782          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6783          + x(20)*yy*zz
6784         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6785          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6786          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6787          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6788          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6789          +x(40)*xx*yy*zz
6790         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6791          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6792          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6793          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6794          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6795          +x(60)*xx*yy*zz
6796         dsc_i   = 0.743d0+x(61)
6797         dp2_i   = 1.9d0+x(62)
6798         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6799                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6800         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6801                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6802         s1=(1+x(63))/(0.1d0 + dscp1)
6803         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6804         s2=(1+x(65))/(0.1d0 + dscp2)
6805         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6806         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6807       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6808 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6809 !     &   sumene4,
6810 !     &   dscp1,dscp2,sumene
6811 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6812         escloc = escloc + sumene
6813        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6814         " escloc",sumene,escloc,it,itype(i,1)
6815 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6816 !     & ,zz,xx,yy
6817 !#define DEBUG
6818 #ifdef DEBUG
6819 !
6820 ! This section to check the numerical derivatives of the energy of ith side
6821 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6822 ! #define DEBUG in the code to turn it on.
6823 !
6824         write (2,*) "sumene               =",sumene
6825         aincr=1.0d-7
6826         xxsave=xx
6827         xx=xx+aincr
6828         write (2,*) xx,yy,zz
6829         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6830         de_dxx_num=(sumenep-sumene)/aincr
6831         xx=xxsave
6832         write (2,*) "xx+ sumene from enesc=",sumenep
6833         yysave=yy
6834         yy=yy+aincr
6835         write (2,*) xx,yy,zz
6836         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6837         de_dyy_num=(sumenep-sumene)/aincr
6838         yy=yysave
6839         write (2,*) "yy+ sumene from enesc=",sumenep
6840         zzsave=zz
6841         zz=zz+aincr
6842         write (2,*) xx,yy,zz
6843         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6844         de_dzz_num=(sumenep-sumene)/aincr
6845         zz=zzsave
6846         write (2,*) "zz+ sumene from enesc=",sumenep
6847         costsave=cost2tab(i+1)
6848         sintsave=sint2tab(i+1)
6849         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6850         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6851         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6852         de_dt_num=(sumenep-sumene)/aincr
6853         write (2,*) " t+ sumene from enesc=",sumenep
6854         cost2tab(i+1)=costsave
6855         sint2tab(i+1)=sintsave
6856 ! End of diagnostics section.
6857 #endif
6858 !
6859 ! Compute the gradient of esc
6860 !
6861 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6862         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6863         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6864         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6865         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6866         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6867         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6868         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6869         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6870         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6871            *(pom_s1/dscp1+pom_s16*dscp1**4)
6872         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6873            *(pom_s2/dscp2+pom_s26*dscp2**4)
6874         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6875         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6876         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6877         +x(40)*yy*zz
6878         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6879         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6880         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6881         +x(60)*yy*zz
6882         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6883               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6884               +(pom1+pom2)*pom_dx
6885 #ifdef DEBUG
6886         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6887 #endif
6888 !
6889         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6890         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6891         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6892         +x(40)*xx*zz
6893         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6894         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6895         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6896         +x(59)*zz**2 +x(60)*xx*zz
6897         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6898               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6899               +(pom1-pom2)*pom_dy
6900 #ifdef DEBUG
6901         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6902 #endif
6903 !
6904         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6905         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6906         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6907         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6908         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6909         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6910         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6911         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6912 #ifdef DEBUG
6913         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6914 #endif
6915 !
6916         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6917         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6918         +pom1*pom_dt1+pom2*pom_dt2
6919 #ifdef DEBUG
6920         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6921 #endif
6922 !
6923 !
6924        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6925        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6926        cosfac2xx=cosfac2*xx
6927        sinfac2yy=sinfac2*yy
6928        do k = 1,3
6929          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6930             vbld_inv(i+1)
6931          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6932             vbld_inv(i)
6933          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6934          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6935 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6936 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6937 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6938 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6939          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6940          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6941          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6942          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6943          dZZ_Ci1(k)=0.0d0
6944          dZZ_Ci(k)=0.0d0
6945          do j=1,3
6946            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6947            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6948            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6949            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6950          enddo
6951
6952          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6953          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6954          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6955          (z_prime(k)-zz*dC_norm(k,i+nres))
6956 !
6957          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6958          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6959        enddo
6960
6961        do k=1,3
6962          dXX_Ctab(k,i)=dXX_Ci(k)
6963          dXX_C1tab(k,i)=dXX_Ci1(k)
6964          dYY_Ctab(k,i)=dYY_Ci(k)
6965          dYY_C1tab(k,i)=dYY_Ci1(k)
6966          dZZ_Ctab(k,i)=dZZ_Ci(k)
6967          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6968          dXX_XYZtab(k,i)=dXX_XYZ(k)
6969          dYY_XYZtab(k,i)=dYY_XYZ(k)
6970          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6971        enddo
6972
6973        do k = 1,3
6974 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6975 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6976 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6977 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6978 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6979 !     &    dt_dci(k)
6980 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6981 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6982          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6983           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6984          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6985           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6986          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6987           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6988        enddo
6989 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6990 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6991
6992 ! to check gradient call subroutine check_grad
6993
6994     1 continue
6995       enddo
6996       return
6997       end subroutine esc
6998 !-----------------------------------------------------------------------------
6999       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7000 !      implicit none
7001       real(kind=8),dimension(65) :: x
7002       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7003         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7004
7005       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7006         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7007         + x(10)*yy*zz
7008       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7009         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7010         + x(20)*yy*zz
7011       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7012         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7013         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7014         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7015         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7016         +x(40)*xx*yy*zz
7017       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7018         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7019         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7020         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7021         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7022         +x(60)*xx*yy*zz
7023       dsc_i   = 0.743d0+x(61)
7024       dp2_i   = 1.9d0+x(62)
7025       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7026                 *(xx*cost2+yy*sint2))
7027       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7028                 *(xx*cost2-yy*sint2))
7029       s1=(1+x(63))/(0.1d0 + dscp1)
7030       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7031       s2=(1+x(65))/(0.1d0 + dscp2)
7032       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7033       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7034        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7035       enesc=sumene
7036       return
7037       end function enesc
7038 #endif
7039 !-----------------------------------------------------------------------------
7040       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7041 !
7042 ! This procedure calculates two-body contact function g(rij) and its derivative:
7043 !
7044 !           eps0ij                                     !       x < -1
7045 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7046 !            0                                         !       x > 1
7047 !
7048 ! where x=(rij-r0ij)/delta
7049 !
7050 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7051 !
7052 !      implicit none
7053       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7054       real(kind=8) :: x,x2,x4,delta
7055 !     delta=0.02D0*r0ij
7056 !      delta=0.2D0*r0ij
7057       x=(rij-r0ij)/delta
7058       if (x.lt.-1.0D0) then
7059         fcont=eps0ij
7060         fprimcont=0.0D0
7061       else if (x.le.1.0D0) then
7062         x2=x*x
7063         x4=x2*x2
7064         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7065         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7066       else
7067         fcont=0.0D0
7068         fprimcont=0.0D0
7069       endif
7070       return
7071       end subroutine gcont
7072 !-----------------------------------------------------------------------------
7073       subroutine splinthet(theti,delta,ss,ssder)
7074 !      implicit real*8 (a-h,o-z)
7075 !      include 'DIMENSIONS'
7076 !      include 'COMMON.VAR'
7077 !      include 'COMMON.GEO'
7078       real(kind=8) :: theti,delta,ss,ssder
7079       real(kind=8) :: thetup,thetlow
7080       thetup=pi-delta
7081       thetlow=delta
7082       if (theti.gt.pipol) then
7083         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7084       else
7085         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7086         ssder=-ssder
7087       endif
7088       return
7089       end subroutine splinthet
7090 !-----------------------------------------------------------------------------
7091       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7092 !      implicit none
7093       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7094       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7095       a1=fprim0*delta/(f1-f0)
7096       a2=3.0d0-2.0d0*a1
7097       a3=a1-2.0d0
7098       ksi=(x-x0)/delta
7099       ksi2=ksi*ksi
7100       ksi3=ksi2*ksi
7101       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7102       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7103       return
7104       end subroutine spline1
7105 !-----------------------------------------------------------------------------
7106       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7107 !      implicit none
7108       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7109       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7110       ksi=(x-x0)/delta
7111       ksi2=ksi*ksi
7112       ksi3=ksi2*ksi
7113       a1=fprim0x*delta
7114       a2=3*(f1x-f0x)-2*fprim0x*delta
7115       a3=fprim0x*delta-2*(f1x-f0x)
7116       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7117       return
7118       end subroutine spline2
7119 !-----------------------------------------------------------------------------
7120 #ifdef CRYST_TOR
7121 !-----------------------------------------------------------------------------
7122       subroutine etor(etors,edihcnstr)
7123 !      implicit real*8 (a-h,o-z)
7124 !      include 'DIMENSIONS'
7125 !      include 'COMMON.VAR'
7126 !      include 'COMMON.GEO'
7127 !      include 'COMMON.LOCAL'
7128 !      include 'COMMON.TORSION'
7129 !      include 'COMMON.INTERACT'
7130 !      include 'COMMON.DERIV'
7131 !      include 'COMMON.CHAIN'
7132 !      include 'COMMON.NAMES'
7133 !      include 'COMMON.IOUNITS'
7134 !      include 'COMMON.FFIELD'
7135 !      include 'COMMON.TORCNSTR'
7136 !      include 'COMMON.CONTROL'
7137       real(kind=8) :: etors,edihcnstr
7138       logical :: lprn
7139 !el local variables
7140       integer :: i,j,
7141       real(kind=8) :: phii,fac,etors_ii
7142
7143 ! Set lprn=.true. for debugging
7144       lprn=.false.
7145 !      lprn=.true.
7146       etors=0.0D0
7147       do i=iphi_start,iphi_end
7148       etors_ii=0.0D0
7149         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7150             .or. itype(i,1).eq.ntyp1) cycle
7151         itori=itortyp(itype(i-2,1))
7152         itori1=itortyp(itype(i-1,1))
7153         phii=phi(i)
7154         gloci=0.0D0
7155 ! Proline-Proline pair is a special case...
7156         if (itori.eq.3 .and. itori1.eq.3) then
7157           if (phii.gt.-dwapi3) then
7158             cosphi=dcos(3*phii)
7159             fac=1.0D0/(1.0D0-cosphi)
7160             etorsi=v1(1,3,3)*fac
7161             etorsi=etorsi+etorsi
7162             etors=etors+etorsi-v1(1,3,3)
7163             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7164             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7165           endif
7166           do j=1,3
7167             v1ij=v1(j+1,itori,itori1)
7168             v2ij=v2(j+1,itori,itori1)
7169             cosphi=dcos(j*phii)
7170             sinphi=dsin(j*phii)
7171             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7172             if (energy_dec) etors_ii=etors_ii+ &
7173                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7174             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7175           enddo
7176         else
7177           do j=1,nterm_old
7178             v1ij=v1(j,itori,itori1)
7179             v2ij=v2(j,itori,itori1)
7180             cosphi=dcos(j*phii)
7181             sinphi=dsin(j*phii)
7182             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7183             if (energy_dec) etors_ii=etors_ii+ &
7184                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7185             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7186           enddo
7187         endif
7188         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7189              'etor',i,etors_ii
7190         if (lprn) &
7191         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7192         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7193         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7194         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7195 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7196       enddo
7197 ! 6/20/98 - dihedral angle constraints
7198       edihcnstr=0.0d0
7199       do i=1,ndih_constr
7200         itori=idih_constr(i)
7201         phii=phi(itori)
7202         difi=phii-phi0(i)
7203         if (difi.gt.drange(i)) then
7204           difi=difi-drange(i)
7205           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7206           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7207         else if (difi.lt.-drange(i)) then
7208           difi=difi+drange(i)
7209           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7210           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7211         endif
7212 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7213 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7214       enddo
7215 !      write (iout,*) 'edihcnstr',edihcnstr
7216       return
7217       end subroutine etor
7218 !-----------------------------------------------------------------------------
7219       subroutine etor_d(etors_d)
7220       real(kind=8) :: etors_d
7221       etors_d=0.0d0
7222       return
7223       end subroutine etor_d
7224 #else
7225 !-----------------------------------------------------------------------------
7226       subroutine etor(etors)
7227 !      implicit real*8 (a-h,o-z)
7228 !      include 'DIMENSIONS'
7229 !      include 'COMMON.VAR'
7230 !      include 'COMMON.GEO'
7231 !      include 'COMMON.LOCAL'
7232 !      include 'COMMON.TORSION'
7233 !      include 'COMMON.INTERACT'
7234 !      include 'COMMON.DERIV'
7235 !      include 'COMMON.CHAIN'
7236 !      include 'COMMON.NAMES'
7237 !      include 'COMMON.IOUNITS'
7238 !      include 'COMMON.FFIELD'
7239 !      include 'COMMON.TORCNSTR'
7240 !      include 'COMMON.CONTROL'
7241       real(kind=8) :: etors,edihcnstr
7242       logical :: lprn
7243 !el local variables
7244       integer :: i,j,iblock,itori,itori1
7245       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7246                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7247 ! Set lprn=.true. for debugging
7248       lprn=.false.
7249 !     lprn=.true.
7250       etors=0.0D0
7251       do i=iphi_start,iphi_end
7252         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7253              .or. itype(i-3,1).eq.ntyp1 &
7254              .or. itype(i,1).eq.ntyp1) cycle
7255         etors_ii=0.0D0
7256          if (iabs(itype(i,1)).eq.20) then
7257          iblock=2
7258          else
7259          iblock=1
7260          endif
7261         itori=itortyp(itype(i-2,1))
7262         itori1=itortyp(itype(i-1,1))
7263         phii=phi(i)
7264         gloci=0.0D0
7265 ! Regular cosine and sine terms
7266         do j=1,nterm(itori,itori1,iblock)
7267           v1ij=v1(j,itori,itori1,iblock)
7268           v2ij=v2(j,itori,itori1,iblock)
7269           cosphi=dcos(j*phii)
7270           sinphi=dsin(j*phii)
7271           etors=etors+v1ij*cosphi+v2ij*sinphi
7272           if (energy_dec) etors_ii=etors_ii+ &
7273                      v1ij*cosphi+v2ij*sinphi
7274           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7275         enddo
7276 ! Lorentz terms
7277 !                         v1
7278 !  E = SUM ----------------------------------- - v1
7279 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7280 !
7281         cosphi=dcos(0.5d0*phii)
7282         sinphi=dsin(0.5d0*phii)
7283         do j=1,nlor(itori,itori1,iblock)
7284           vl1ij=vlor1(j,itori,itori1)
7285           vl2ij=vlor2(j,itori,itori1)
7286           vl3ij=vlor3(j,itori,itori1)
7287           pom=vl2ij*cosphi+vl3ij*sinphi
7288           pom1=1.0d0/(pom*pom+1.0d0)
7289           etors=etors+vl1ij*pom1
7290           if (energy_dec) etors_ii=etors_ii+ &
7291                      vl1ij*pom1
7292           pom=-pom*pom1*pom1
7293           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7294         enddo
7295 ! Subtract the constant term
7296         etors=etors-v0(itori,itori1,iblock)
7297           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7298                'etor',i,etors_ii-v0(itori,itori1,iblock)
7299         if (lprn) &
7300         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7301         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7302         (v1(j,itori,itori1,iblock),j=1,6),&
7303         (v2(j,itori,itori1,iblock),j=1,6)
7304         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7305 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7306       enddo
7307 ! 6/20/98 - dihedral angle constraints
7308       return
7309       end subroutine etor
7310 !C The rigorous attempt to derive energy function
7311 !-------------------------------------------------------------------------------------------
7312       subroutine etor_kcc(etors)
7313       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7314       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7315        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7316        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7317        gradvalst2,etori
7318       logical lprn
7319       integer :: i,j,itori,itori1,nval,k,l
7320
7321       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7322       etors=0.0D0
7323       do i=iphi_start,iphi_end
7324 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7325 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7326 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7327 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7328         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7329            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7330         itori=itortyp(itype(i-2,1))
7331         itori1=itortyp(itype(i-1,1))
7332         phii=phi(i)
7333         glocig=0.0D0
7334         glocit1=0.0d0
7335         glocit2=0.0d0
7336 !C to avoid multiple devision by 2
7337 !c        theti22=0.5d0*theta(i)
7338 !C theta 12 is the theta_1 /2
7339 !C theta 22 is theta_2 /2
7340 !c        theti12=0.5d0*theta(i-1)
7341 !C and appropriate sinus function
7342         sinthet1=dsin(theta(i-1))
7343         sinthet2=dsin(theta(i))
7344         costhet1=dcos(theta(i-1))
7345         costhet2=dcos(theta(i))
7346 !C to speed up lets store its mutliplication
7347         sint1t2=sinthet2*sinthet1
7348         sint1t2n=1.0d0
7349 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7350 !C +d_n*sin(n*gamma)) *
7351 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7352 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7353         nval=nterm_kcc_Tb(itori,itori1)
7354         c1(0)=0.0d0
7355         c2(0)=0.0d0
7356         c1(1)=1.0d0
7357         c2(1)=1.0d0
7358         do j=2,nval
7359           c1(j)=c1(j-1)*costhet1
7360           c2(j)=c2(j-1)*costhet2
7361         enddo
7362         etori=0.0d0
7363
7364        do j=1,nterm_kcc(itori,itori1)
7365           cosphi=dcos(j*phii)
7366           sinphi=dsin(j*phii)
7367           sint1t2n1=sint1t2n
7368           sint1t2n=sint1t2n*sint1t2
7369           sumvalc=0.0d0
7370           gradvalct1=0.0d0
7371           gradvalct2=0.0d0
7372           do k=1,nval
7373             do l=1,nval
7374               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7375               gradvalct1=gradvalct1+ &
7376                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7377               gradvalct2=gradvalct2+ &
7378                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7379             enddo
7380           enddo
7381           gradvalct1=-gradvalct1*sinthet1
7382           gradvalct2=-gradvalct2*sinthet2
7383           sumvals=0.0d0
7384           gradvalst1=0.0d0
7385           gradvalst2=0.0d0
7386           do k=1,nval
7387             do l=1,nval
7388               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7389               gradvalst1=gradvalst1+ &
7390                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7391               gradvalst2=gradvalst2+ &
7392                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7393             enddo
7394           enddo
7395           gradvalst1=-gradvalst1*sinthet1
7396           gradvalst2=-gradvalst2*sinthet2
7397           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7398           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7399 !C glocig is the gradient local i site in gamma
7400           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7401 !C now gradient over theta_1
7402          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7403         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7404          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7405         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7406         enddo ! j
7407         etors=etors+etori
7408         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7409 !C derivative over theta1
7410         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7411 !C now derivative over theta2
7412         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7413         if (lprn) then
7414          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7415             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7416           write (iout,*) "c1",(c1(k),k=0,nval), &
7417          " c2",(c2(k),k=0,nval)
7418         endif
7419       enddo
7420       return
7421        end  subroutine etor_kcc
7422 !------------------------------------------------------------------------------
7423
7424         subroutine etor_constr(edihcnstr)
7425       real(kind=8) :: etors,edihcnstr
7426       logical :: lprn
7427 !el local variables
7428       integer :: i,j,iblock,itori,itori1
7429       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7430                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7431                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7432
7433       if (raw_psipred) then
7434         do i=idihconstr_start,idihconstr_end
7435           itori=idih_constr(i)
7436           phii=phi(itori)
7437           gaudih_i=vpsipred(1,i)
7438           gauder_i=0.0d0
7439           do j=1,2
7440             s = sdihed(j,i)
7441             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7442             dexpcos_i=dexp(-cos_i*cos_i)
7443             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7444           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7445                  *cos_i*dexpcos_i/s**2
7446           enddo
7447           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7448           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7449           if (energy_dec) &
7450           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7451           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7452           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7453           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7454           -wdihc*dlog(gaudih_i)
7455         enddo
7456       else
7457
7458       do i=idihconstr_start,idihconstr_end
7459         itori=idih_constr(i)
7460         phii=phi(itori)
7461         difi=pinorm(phii-phi0(i))
7462         if (difi.gt.drange(i)) then
7463           difi=difi-drange(i)
7464           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7465           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7466         else if (difi.lt.-drange(i)) then
7467           difi=difi+drange(i)
7468           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7469           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7470         else
7471           difi=0.0
7472         endif
7473       enddo
7474
7475       endif
7476
7477       return
7478
7479       end subroutine etor_constr
7480 !-----------------------------------------------------------------------------
7481       subroutine etor_d(etors_d)
7482 ! 6/23/01 Compute double torsional energy
7483 !      implicit real*8 (a-h,o-z)
7484 !      include 'DIMENSIONS'
7485 !      include 'COMMON.VAR'
7486 !      include 'COMMON.GEO'
7487 !      include 'COMMON.LOCAL'
7488 !      include 'COMMON.TORSION'
7489 !      include 'COMMON.INTERACT'
7490 !      include 'COMMON.DERIV'
7491 !      include 'COMMON.CHAIN'
7492 !      include 'COMMON.NAMES'
7493 !      include 'COMMON.IOUNITS'
7494 !      include 'COMMON.FFIELD'
7495 !      include 'COMMON.TORCNSTR'
7496       real(kind=8) :: etors_d,etors_d_ii
7497       logical :: lprn
7498 !el local variables
7499       integer :: i,j,k,l,itori,itori1,itori2,iblock
7500       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7501                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7502                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7503                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7504 ! Set lprn=.true. for debugging
7505       lprn=.false.
7506 !     lprn=.true.
7507       etors_d=0.0D0
7508 !      write(iout,*) "a tu??"
7509       do i=iphid_start,iphid_end
7510         etors_d_ii=0.0D0
7511         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7512             .or. itype(i-3,1).eq.ntyp1 &
7513             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7514         itori=itortyp(itype(i-2,1))
7515         itori1=itortyp(itype(i-1,1))
7516         itori2=itortyp(itype(i,1))
7517         phii=phi(i)
7518         phii1=phi(i+1)
7519         gloci1=0.0D0
7520         gloci2=0.0D0
7521         iblock=1
7522         if (iabs(itype(i+1,1)).eq.20) iblock=2
7523
7524 ! Regular cosine and sine terms
7525         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7526           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7527           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7528           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7529           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7530           cosphi1=dcos(j*phii)
7531           sinphi1=dsin(j*phii)
7532           cosphi2=dcos(j*phii1)
7533           sinphi2=dsin(j*phii1)
7534           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7535            v2cij*cosphi2+v2sij*sinphi2
7536           if (energy_dec) etors_d_ii=etors_d_ii+ &
7537            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7538           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7539           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7540         enddo
7541         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7542           do l=1,k-1
7543             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7544             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7545             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7546             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7547             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7548             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7549             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7550             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7551             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7552               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7553             if (energy_dec) etors_d_ii=etors_d_ii+ &
7554               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7555               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7556             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7557               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7558             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7559               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7560           enddo
7561         enddo
7562         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7563                             'etor_d',i,etors_d_ii
7564         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7565         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7566       enddo
7567       return
7568       end subroutine etor_d
7569 #endif
7570
7571       subroutine ebend_kcc(etheta)
7572       logical lprn
7573       double precision thybt1(maxang_kcc),etheta
7574       integer :: i,iti,j,ihelp
7575       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7576 !C Set lprn=.true. for debugging
7577       lprn=energy_dec
7578 !c     lprn=.true.
7579 !C      print *,"wchodze kcc"
7580       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7581       etheta=0.0D0
7582       do i=ithet_start,ithet_end
7583 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7584         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7585        .or.itype(i,1).eq.ntyp1) cycle
7586         iti=iabs(itortyp(itype(i-1,1)))
7587         sinthet=dsin(theta(i))
7588         costhet=dcos(theta(i))
7589         do j=1,nbend_kcc_Tb(iti)
7590           thybt1(j)=v1bend_chyb(j,iti)
7591         enddo
7592         sumth1thyb=v1bend_chyb(0,iti)+ &
7593          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7594         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7595          sumth1thyb
7596         ihelp=nbend_kcc_Tb(iti)-1
7597         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7598         etheta=etheta+sumth1thyb
7599 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7600         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7601       enddo
7602       return
7603       end subroutine ebend_kcc
7604 !c------------
7605 !c-------------------------------------------------------------------------------------
7606       subroutine etheta_constr(ethetacnstr)
7607       real (kind=8) :: ethetacnstr,thetiii,difi
7608       integer :: i,itheta
7609       ethetacnstr=0.0d0
7610 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7611       do i=ithetaconstr_start,ithetaconstr_end
7612         itheta=itheta_constr(i)
7613         thetiii=theta(itheta)
7614         difi=pinorm(thetiii-theta_constr0(i))
7615         if (difi.gt.theta_drange(i)) then
7616           difi=difi-theta_drange(i)
7617           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7618           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7619          +for_thet_constr(i)*difi**3
7620         else if (difi.lt.-drange(i)) then
7621           difi=difi+drange(i)
7622           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7623           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7624           +for_thet_constr(i)*difi**3
7625         else
7626           difi=0.0
7627         endif
7628        if (energy_dec) then
7629         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7630          i,itheta,rad2deg*thetiii,&
7631          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7632          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7633          gloc(itheta+nphi-2,icg)
7634         endif
7635       enddo
7636       return
7637       end subroutine etheta_constr
7638
7639 !-----------------------------------------------------------------------------
7640       subroutine eback_sc_corr(esccor)
7641 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7642 !        conformational states; temporarily implemented as differences
7643 !        between UNRES torsional potentials (dependent on three types of
7644 !        residues) and the torsional potentials dependent on all 20 types
7645 !        of residues computed from AM1  energy surfaces of terminally-blocked
7646 !        amino-acid residues.
7647 !      implicit real*8 (a-h,o-z)
7648 !      include 'DIMENSIONS'
7649 !      include 'COMMON.VAR'
7650 !      include 'COMMON.GEO'
7651 !      include 'COMMON.LOCAL'
7652 !      include 'COMMON.TORSION'
7653 !      include 'COMMON.SCCOR'
7654 !      include 'COMMON.INTERACT'
7655 !      include 'COMMON.DERIV'
7656 !      include 'COMMON.CHAIN'
7657 !      include 'COMMON.NAMES'
7658 !      include 'COMMON.IOUNITS'
7659 !      include 'COMMON.FFIELD'
7660 !      include 'COMMON.CONTROL'
7661       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7662                    cosphi,sinphi
7663       logical :: lprn
7664       integer :: i,interty,j,isccori,isccori1,intertyp
7665 ! Set lprn=.true. for debugging
7666       lprn=.false.
7667 !      lprn=.true.
7668 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7669       esccor=0.0D0
7670       do i=itau_start,itau_end
7671         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7672         esccor_ii=0.0D0
7673         isccori=isccortyp(itype(i-2,1))
7674         isccori1=isccortyp(itype(i-1,1))
7675
7676 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7677         phii=phi(i)
7678         do intertyp=1,3 !intertyp
7679          esccor_ii=0.0D0
7680 !c Added 09 May 2012 (Adasko)
7681 !c  Intertyp means interaction type of backbone mainchain correlation:
7682 !   1 = SC...Ca...Ca...Ca
7683 !   2 = Ca...Ca...Ca...SC
7684 !   3 = SC...Ca...Ca...SCi
7685         gloci=0.0D0
7686         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7687             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7688             (itype(i-1,1).eq.ntyp1))) &
7689           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7690            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7691            .or.(itype(i,1).eq.ntyp1))) &
7692           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7693             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7694             (itype(i-3,1).eq.ntyp1)))) cycle
7695         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7696         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7697        cycle
7698        do j=1,nterm_sccor(isccori,isccori1)
7699           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7700           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7701           cosphi=dcos(j*tauangle(intertyp,i))
7702           sinphi=dsin(j*tauangle(intertyp,i))
7703           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7704           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7705           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7706         enddo
7707         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7708                                 'esccor',i,intertyp,esccor_ii
7709 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7710         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7711         if (lprn) &
7712         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7713         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7714         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7715         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7716         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7717        enddo !intertyp
7718       enddo
7719
7720       return
7721       end subroutine eback_sc_corr
7722 !-----------------------------------------------------------------------------
7723       subroutine multibody(ecorr)
7724 ! This subroutine calculates multi-body contributions to energy following
7725 ! the idea of Skolnick et al. If side chains I and J make a contact and
7726 ! at the same time side chains I+1 and J+1 make a contact, an extra
7727 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7728 !      implicit real*8 (a-h,o-z)
7729 !      include 'DIMENSIONS'
7730 !      include 'COMMON.IOUNITS'
7731 !      include 'COMMON.DERIV'
7732 !      include 'COMMON.INTERACT'
7733 !      include 'COMMON.CONTACTS'
7734       real(kind=8),dimension(3) :: gx,gx1
7735       logical :: lprn
7736       real(kind=8) :: ecorr
7737       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7738 ! Set lprn=.true. for debugging
7739       lprn=.false.
7740
7741       if (lprn) then
7742         write (iout,'(a)') 'Contact function values:'
7743         do i=nnt,nct-2
7744           write (iout,'(i2,20(1x,i2,f10.5))') &
7745               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7746         enddo
7747       endif
7748       ecorr=0.0D0
7749
7750 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7751 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7752       do i=nnt,nct
7753         do j=1,3
7754           gradcorr(j,i)=0.0D0
7755           gradxorr(j,i)=0.0D0
7756         enddo
7757       enddo
7758       do i=nnt,nct-2
7759
7760         DO ISHIFT = 3,4
7761
7762         i1=i+ishift
7763         num_conti=num_cont(i)
7764         num_conti1=num_cont(i1)
7765         do jj=1,num_conti
7766           j=jcont(jj,i)
7767           do kk=1,num_conti1
7768             j1=jcont(kk,i1)
7769             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7770 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7771 !d   &                   ' ishift=',ishift
7772 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7773 ! The system gains extra energy.
7774               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7775             endif   ! j1==j+-ishift
7776           enddo     ! kk
7777         enddo       ! jj
7778
7779         ENDDO ! ISHIFT
7780
7781       enddo         ! i
7782       return
7783       end subroutine multibody
7784 !-----------------------------------------------------------------------------
7785       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7786 !      implicit real*8 (a-h,o-z)
7787 !      include 'DIMENSIONS'
7788 !      include 'COMMON.IOUNITS'
7789 !      include 'COMMON.DERIV'
7790 !      include 'COMMON.INTERACT'
7791 !      include 'COMMON.CONTACTS'
7792       real(kind=8),dimension(3) :: gx,gx1
7793       logical :: lprn
7794       integer :: i,j,k,l,jj,kk,m,ll
7795       real(kind=8) :: eij,ekl
7796       lprn=.false.
7797       eij=facont(jj,i)
7798       ekl=facont(kk,k)
7799 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7800 ! Calculate the multi-body contribution to energy.
7801 ! Calculate multi-body contributions to the gradient.
7802 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7803 !d   & k,l,(gacont(m,kk,k),m=1,3)
7804       do m=1,3
7805         gx(m) =ekl*gacont(m,jj,i)
7806         gx1(m)=eij*gacont(m,kk,k)
7807         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7808         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7809         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7810         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7811       enddo
7812       do m=i,j-1
7813         do ll=1,3
7814           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7815         enddo
7816       enddo
7817       do m=k,l-1
7818         do ll=1,3
7819           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7820         enddo
7821       enddo
7822       esccorr=-eij*ekl
7823       return
7824       end function esccorr
7825 !-----------------------------------------------------------------------------
7826       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7827 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7828 !      implicit real*8 (a-h,o-z)
7829 !      include 'DIMENSIONS'
7830 !      include 'COMMON.IOUNITS'
7831 #ifdef MPI
7832       include "mpif.h"
7833 !      integer :: maxconts !max_cont=maxconts  =nres/4
7834       integer,parameter :: max_dim=26
7835       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7836       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7837 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7838 !el      common /przechowalnia/ zapas
7839       integer :: status(MPI_STATUS_SIZE)
7840       integer,dimension((nres/4)*2) :: req !maxconts*2
7841       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7842 #endif
7843 !      include 'COMMON.SETUP'
7844 !      include 'COMMON.FFIELD'
7845 !      include 'COMMON.DERIV'
7846 !      include 'COMMON.INTERACT'
7847 !      include 'COMMON.CONTACTS'
7848 !      include 'COMMON.CONTROL'
7849 !      include 'COMMON.LOCAL'
7850       real(kind=8),dimension(3) :: gx,gx1
7851       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7852       logical :: lprn,ldone
7853 !el local variables
7854       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7855               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7856
7857 ! Set lprn=.true. for debugging
7858       lprn=.false.
7859 #ifdef MPI
7860 !      maxconts=nres/4
7861       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7862       n_corr=0
7863       n_corr1=0
7864       if (nfgtasks.le.1) goto 30
7865       if (lprn) then
7866         write (iout,'(a)') 'Contact function values before RECEIVE:'
7867         do i=nnt,nct-2
7868           write (iout,'(2i3,50(1x,i2,f5.2))') &
7869           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7870           j=1,num_cont_hb(i))
7871         enddo
7872       endif
7873       call flush(iout)
7874       do i=1,ntask_cont_from
7875         ncont_recv(i)=0
7876       enddo
7877       do i=1,ntask_cont_to
7878         ncont_sent(i)=0
7879       enddo
7880 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7881 !     & ntask_cont_to
7882 ! Make the list of contacts to send to send to other procesors
7883 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7884 !      call flush(iout)
7885       do i=iturn3_start,iturn3_end
7886 !        write (iout,*) "make contact list turn3",i," num_cont",
7887 !     &    num_cont_hb(i)
7888         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7889       enddo
7890       do i=iturn4_start,iturn4_end
7891 !        write (iout,*) "make contact list turn4",i," num_cont",
7892 !     &   num_cont_hb(i)
7893         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7894       enddo
7895       do ii=1,nat_sent
7896         i=iat_sent(ii)
7897 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7898 !     &    num_cont_hb(i)
7899         do j=1,num_cont_hb(i)
7900         do k=1,4
7901           jjc=jcont_hb(j,i)
7902           iproc=iint_sent_local(k,jjc,ii)
7903 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7904           if (iproc.gt.0) then
7905             ncont_sent(iproc)=ncont_sent(iproc)+1
7906             nn=ncont_sent(iproc)
7907             zapas(1,nn,iproc)=i
7908             zapas(2,nn,iproc)=jjc
7909             zapas(3,nn,iproc)=facont_hb(j,i)
7910             zapas(4,nn,iproc)=ees0p(j,i)
7911             zapas(5,nn,iproc)=ees0m(j,i)
7912             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7913             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7914             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7915             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7916             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7917             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7918             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7919             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7920             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7921             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7922             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7923             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7924             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7925             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7926             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7927             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7928             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7929             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7930             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7931             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7932             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7933           endif
7934         enddo
7935         enddo
7936       enddo
7937       if (lprn) then
7938       write (iout,*) &
7939         "Numbers of contacts to be sent to other processors",&
7940         (ncont_sent(i),i=1,ntask_cont_to)
7941       write (iout,*) "Contacts sent"
7942       do ii=1,ntask_cont_to
7943         nn=ncont_sent(ii)
7944         iproc=itask_cont_to(ii)
7945         write (iout,*) nn," contacts to processor",iproc,&
7946          " of CONT_TO_COMM group"
7947         do i=1,nn
7948           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7949         enddo
7950       enddo
7951       call flush(iout)
7952       endif
7953       CorrelType=477
7954       CorrelID=fg_rank+1
7955       CorrelType1=478
7956       CorrelID1=nfgtasks+fg_rank+1
7957       ireq=0
7958 ! Receive the numbers of needed contacts from other processors
7959       do ii=1,ntask_cont_from
7960         iproc=itask_cont_from(ii)
7961         ireq=ireq+1
7962         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7963           FG_COMM,req(ireq),IERR)
7964       enddo
7965 !      write (iout,*) "IRECV ended"
7966 !      call flush(iout)
7967 ! Send the number of contacts needed by other processors
7968       do ii=1,ntask_cont_to
7969         iproc=itask_cont_to(ii)
7970         ireq=ireq+1
7971         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7972           FG_COMM,req(ireq),IERR)
7973       enddo
7974 !      write (iout,*) "ISEND ended"
7975 !      write (iout,*) "number of requests (nn)",ireq
7976       call flush(iout)
7977       if (ireq.gt.0) &
7978         call MPI_Waitall(ireq,req,status_array,ierr)
7979 !      write (iout,*)
7980 !     &  "Numbers of contacts to be received from other processors",
7981 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7982 !      call flush(iout)
7983 ! Receive contacts
7984       ireq=0
7985       do ii=1,ntask_cont_from
7986         iproc=itask_cont_from(ii)
7987         nn=ncont_recv(ii)
7988 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7989 !     &   " of CONT_TO_COMM group"
7990         call flush(iout)
7991         if (nn.gt.0) then
7992           ireq=ireq+1
7993           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7994           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7995 !          write (iout,*) "ireq,req",ireq,req(ireq)
7996         endif
7997       enddo
7998 ! Send the contacts to processors that need them
7999       do ii=1,ntask_cont_to
8000         iproc=itask_cont_to(ii)
8001         nn=ncont_sent(ii)
8002 !        write (iout,*) nn," contacts to processor",iproc,
8003 !     &   " of CONT_TO_COMM group"
8004         if (nn.gt.0) then
8005           ireq=ireq+1
8006           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8007             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8008 !          write (iout,*) "ireq,req",ireq,req(ireq)
8009 !          do i=1,nn
8010 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8011 !          enddo
8012         endif
8013       enddo
8014 !      write (iout,*) "number of requests (contacts)",ireq
8015 !      write (iout,*) "req",(req(i),i=1,4)
8016 !      call flush(iout)
8017       if (ireq.gt.0) &
8018        call MPI_Waitall(ireq,req,status_array,ierr)
8019       do iii=1,ntask_cont_from
8020         iproc=itask_cont_from(iii)
8021         nn=ncont_recv(iii)
8022         if (lprn) then
8023         write (iout,*) "Received",nn," contacts from processor",iproc,&
8024          " of CONT_FROM_COMM group"
8025         call flush(iout)
8026         do i=1,nn
8027           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8028         enddo
8029         call flush(iout)
8030         endif
8031         do i=1,nn
8032           ii=zapas_recv(1,i,iii)
8033 ! Flag the received contacts to prevent double-counting
8034           jj=-zapas_recv(2,i,iii)
8035 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8036 !          call flush(iout)
8037           nnn=num_cont_hb(ii)+1
8038           num_cont_hb(ii)=nnn
8039           jcont_hb(nnn,ii)=jj
8040           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8041           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8042           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8043           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8044           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8045           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8046           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8047           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8048           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8049           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8050           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8051           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8052           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8053           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8054           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8055           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8056           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8057           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8058           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8059           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8060           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8061           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8062           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8063           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8064         enddo
8065       enddo
8066       call flush(iout)
8067       if (lprn) then
8068         write (iout,'(a)') 'Contact function values after receive:'
8069         do i=nnt,nct-2
8070           write (iout,'(2i3,50(1x,i3,f5.2))') &
8071           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8072           j=1,num_cont_hb(i))
8073         enddo
8074         call flush(iout)
8075       endif
8076    30 continue
8077 #endif
8078       if (lprn) then
8079         write (iout,'(a)') 'Contact function values:'
8080         do i=nnt,nct-2
8081           write (iout,'(2i3,50(1x,i3,f5.2))') &
8082           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8083           j=1,num_cont_hb(i))
8084         enddo
8085       endif
8086       ecorr=0.0D0
8087
8088 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8089 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8090 ! Remove the loop below after debugging !!!
8091       do i=nnt,nct
8092         do j=1,3
8093           gradcorr(j,i)=0.0D0
8094           gradxorr(j,i)=0.0D0
8095         enddo
8096       enddo
8097 ! Calculate the local-electrostatic correlation terms
8098       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8099         i1=i+1
8100         num_conti=num_cont_hb(i)
8101         num_conti1=num_cont_hb(i+1)
8102         do jj=1,num_conti
8103           j=jcont_hb(jj,i)
8104           jp=iabs(j)
8105           do kk=1,num_conti1
8106             j1=jcont_hb(kk,i1)
8107             jp1=iabs(j1)
8108 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8109 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8110             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8111                 .or. j.lt.0 .and. j1.gt.0) .and. &
8112                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8113 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8114 ! The system gains extra energy.
8115               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8116               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8117                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8118               n_corr=n_corr+1
8119             else if (j1.eq.j) then
8120 ! Contacts I-J and I-(J+1) occur simultaneously.
8121 ! The system loses extra energy.
8122 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8123             endif
8124           enddo ! kk
8125           do kk=1,num_conti
8126             j1=jcont_hb(kk,i)
8127 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8128 !    &         ' jj=',jj,' kk=',kk
8129             if (j1.eq.j+1) then
8130 ! Contacts I-J and (I+1)-J occur simultaneously.
8131 ! The system loses extra energy.
8132 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8133             endif ! j1==j+1
8134           enddo ! kk
8135         enddo ! jj
8136       enddo ! i
8137       return
8138       end subroutine multibody_hb
8139 !-----------------------------------------------------------------------------
8140       subroutine add_hb_contact(ii,jj,itask)
8141 !      implicit real*8 (a-h,o-z)
8142 !      include "DIMENSIONS"
8143 !      include "COMMON.IOUNITS"
8144 !      include "COMMON.CONTACTS"
8145 !      integer,parameter :: maxconts=nres/4
8146       integer,parameter :: max_dim=26
8147       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8148 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8149 !      common /przechowalnia/ zapas
8150       integer :: i,j,ii,jj,iproc,nn,jjc
8151       integer,dimension(4) :: itask
8152 !      write (iout,*) "itask",itask
8153       do i=1,2
8154         iproc=itask(i)
8155         if (iproc.gt.0) then
8156           do j=1,num_cont_hb(ii)
8157             jjc=jcont_hb(j,ii)
8158 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8159             if (jjc.eq.jj) then
8160               ncont_sent(iproc)=ncont_sent(iproc)+1
8161               nn=ncont_sent(iproc)
8162               zapas(1,nn,iproc)=ii
8163               zapas(2,nn,iproc)=jjc
8164               zapas(3,nn,iproc)=facont_hb(j,ii)
8165               zapas(4,nn,iproc)=ees0p(j,ii)
8166               zapas(5,nn,iproc)=ees0m(j,ii)
8167               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8168               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8169               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8170               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8171               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8172               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8173               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8174               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8175               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8176               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8177               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8178               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8179               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8180               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8181               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8182               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8183               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8184               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8185               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8186               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8187               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8188               exit
8189             endif
8190           enddo
8191         endif
8192       enddo
8193       return
8194       end subroutine add_hb_contact
8195 !-----------------------------------------------------------------------------
8196       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8197 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8198 !      implicit real*8 (a-h,o-z)
8199 !      include 'DIMENSIONS'
8200 !      include 'COMMON.IOUNITS'
8201       integer,parameter :: max_dim=70
8202 #ifdef MPI
8203       include "mpif.h"
8204 !      integer :: maxconts !max_cont=maxconts=nres/4
8205       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8206       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8207 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8208 !      common /przechowalnia/ zapas
8209       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8210         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8211         ierr,iii,nnn
8212 #endif
8213 !      include 'COMMON.SETUP'
8214 !      include 'COMMON.FFIELD'
8215 !      include 'COMMON.DERIV'
8216 !      include 'COMMON.LOCAL'
8217 !      include 'COMMON.INTERACT'
8218 !      include 'COMMON.CONTACTS'
8219 !      include 'COMMON.CHAIN'
8220 !      include 'COMMON.CONTROL'
8221       real(kind=8),dimension(3) :: gx,gx1
8222       integer,dimension(nres) :: num_cont_hb_old
8223       logical :: lprn,ldone
8224 !EL      double precision eello4,eello5,eelo6,eello_turn6
8225 !EL      external eello4,eello5,eello6,eello_turn6
8226 !el local variables
8227       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8228               j1,jp1,i1,num_conti1
8229       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8230       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8231
8232 ! Set lprn=.true. for debugging
8233       lprn=.false.
8234       eturn6=0.0d0
8235 #ifdef MPI
8236 !      maxconts=nres/4
8237       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8238       do i=1,nres
8239         num_cont_hb_old(i)=num_cont_hb(i)
8240       enddo
8241       n_corr=0
8242       n_corr1=0
8243       if (nfgtasks.le.1) goto 30
8244       if (lprn) then
8245         write (iout,'(a)') 'Contact function values before RECEIVE:'
8246         do i=nnt,nct-2
8247           write (iout,'(2i3,50(1x,i2,f5.2))') &
8248           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8249           j=1,num_cont_hb(i))
8250         enddo
8251       endif
8252       call flush(iout)
8253       do i=1,ntask_cont_from
8254         ncont_recv(i)=0
8255       enddo
8256       do i=1,ntask_cont_to
8257         ncont_sent(i)=0
8258       enddo
8259 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8260 !     & ntask_cont_to
8261 ! Make the list of contacts to send to send to other procesors
8262       do i=iturn3_start,iturn3_end
8263 !        write (iout,*) "make contact list turn3",i," num_cont",
8264 !     &    num_cont_hb(i)
8265         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8266       enddo
8267       do i=iturn4_start,iturn4_end
8268 !        write (iout,*) "make contact list turn4",i," num_cont",
8269 !     &   num_cont_hb(i)
8270         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8271       enddo
8272       do ii=1,nat_sent
8273         i=iat_sent(ii)
8274 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8275 !     &    num_cont_hb(i)
8276         do j=1,num_cont_hb(i)
8277         do k=1,4
8278           jjc=jcont_hb(j,i)
8279           iproc=iint_sent_local(k,jjc,ii)
8280 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8281           if (iproc.ne.0) then
8282             ncont_sent(iproc)=ncont_sent(iproc)+1
8283             nn=ncont_sent(iproc)
8284             zapas(1,nn,iproc)=i
8285             zapas(2,nn,iproc)=jjc
8286             zapas(3,nn,iproc)=d_cont(j,i)
8287             ind=3
8288             do kk=1,3
8289               ind=ind+1
8290               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8291             enddo
8292             do kk=1,2
8293               do ll=1,2
8294                 ind=ind+1
8295                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8296               enddo
8297             enddo
8298             do jj=1,5
8299               do kk=1,3
8300                 do ll=1,2
8301                   do mm=1,2
8302                     ind=ind+1
8303                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8304                   enddo
8305                 enddo
8306               enddo
8307             enddo
8308           endif
8309         enddo
8310         enddo
8311       enddo
8312       if (lprn) then
8313       write (iout,*) &
8314         "Numbers of contacts to be sent to other processors",&
8315         (ncont_sent(i),i=1,ntask_cont_to)
8316       write (iout,*) "Contacts sent"
8317       do ii=1,ntask_cont_to
8318         nn=ncont_sent(ii)
8319         iproc=itask_cont_to(ii)
8320         write (iout,*) nn," contacts to processor",iproc,&
8321          " of CONT_TO_COMM group"
8322         do i=1,nn
8323           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8324         enddo
8325       enddo
8326       call flush(iout)
8327       endif
8328       CorrelType=477
8329       CorrelID=fg_rank+1
8330       CorrelType1=478
8331       CorrelID1=nfgtasks+fg_rank+1
8332       ireq=0
8333 ! Receive the numbers of needed contacts from other processors
8334       do ii=1,ntask_cont_from
8335         iproc=itask_cont_from(ii)
8336         ireq=ireq+1
8337         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8338           FG_COMM,req(ireq),IERR)
8339       enddo
8340 !      write (iout,*) "IRECV ended"
8341 !      call flush(iout)
8342 ! Send the number of contacts needed by other processors
8343       do ii=1,ntask_cont_to
8344         iproc=itask_cont_to(ii)
8345         ireq=ireq+1
8346         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8347           FG_COMM,req(ireq),IERR)
8348       enddo
8349 !      write (iout,*) "ISEND ended"
8350 !      write (iout,*) "number of requests (nn)",ireq
8351       call flush(iout)
8352       if (ireq.gt.0) &
8353         call MPI_Waitall(ireq,req,status_array,ierr)
8354 !      write (iout,*)
8355 !     &  "Numbers of contacts to be received from other processors",
8356 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8357 !      call flush(iout)
8358 ! Receive contacts
8359       ireq=0
8360       do ii=1,ntask_cont_from
8361         iproc=itask_cont_from(ii)
8362         nn=ncont_recv(ii)
8363 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8364 !     &   " of CONT_TO_COMM group"
8365         call flush(iout)
8366         if (nn.gt.0) then
8367           ireq=ireq+1
8368           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8369           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8370 !          write (iout,*) "ireq,req",ireq,req(ireq)
8371         endif
8372       enddo
8373 ! Send the contacts to processors that need them
8374       do ii=1,ntask_cont_to
8375         iproc=itask_cont_to(ii)
8376         nn=ncont_sent(ii)
8377 !        write (iout,*) nn," contacts to processor",iproc,
8378 !     &   " of CONT_TO_COMM group"
8379         if (nn.gt.0) then
8380           ireq=ireq+1
8381           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8382             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8383 !          write (iout,*) "ireq,req",ireq,req(ireq)
8384 !          do i=1,nn
8385 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8386 !          enddo
8387         endif
8388       enddo
8389 !      write (iout,*) "number of requests (contacts)",ireq
8390 !      write (iout,*) "req",(req(i),i=1,4)
8391 !      call flush(iout)
8392       if (ireq.gt.0) &
8393        call MPI_Waitall(ireq,req,status_array,ierr)
8394       do iii=1,ntask_cont_from
8395         iproc=itask_cont_from(iii)
8396         nn=ncont_recv(iii)
8397         if (lprn) then
8398         write (iout,*) "Received",nn," contacts from processor",iproc,&
8399          " of CONT_FROM_COMM group"
8400         call flush(iout)
8401         do i=1,nn
8402           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8403         enddo
8404         call flush(iout)
8405         endif
8406         do i=1,nn
8407           ii=zapas_recv(1,i,iii)
8408 ! Flag the received contacts to prevent double-counting
8409           jj=-zapas_recv(2,i,iii)
8410 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8411 !          call flush(iout)
8412           nnn=num_cont_hb(ii)+1
8413           num_cont_hb(ii)=nnn
8414           jcont_hb(nnn,ii)=jj
8415           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8416           ind=3
8417           do kk=1,3
8418             ind=ind+1
8419             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8420           enddo
8421           do kk=1,2
8422             do ll=1,2
8423               ind=ind+1
8424               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8425             enddo
8426           enddo
8427           do jj=1,5
8428             do kk=1,3
8429               do ll=1,2
8430                 do mm=1,2
8431                   ind=ind+1
8432                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8433                 enddo
8434               enddo
8435             enddo
8436           enddo
8437         enddo
8438       enddo
8439       call flush(iout)
8440       if (lprn) then
8441         write (iout,'(a)') 'Contact function values after receive:'
8442         do i=nnt,nct-2
8443           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8444           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8445           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8446         enddo
8447         call flush(iout)
8448       endif
8449    30 continue
8450 #endif
8451       if (lprn) then
8452         write (iout,'(a)') 'Contact function values:'
8453         do i=nnt,nct-2
8454           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8455           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8456           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8457         enddo
8458       endif
8459       ecorr=0.0D0
8460       ecorr5=0.0d0
8461       ecorr6=0.0d0
8462
8463 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8464 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8465 ! Remove the loop below after debugging !!!
8466       do i=nnt,nct
8467         do j=1,3
8468           gradcorr(j,i)=0.0D0
8469           gradxorr(j,i)=0.0D0
8470         enddo
8471       enddo
8472 ! Calculate the dipole-dipole interaction energies
8473       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8474       do i=iatel_s,iatel_e+1
8475         num_conti=num_cont_hb(i)
8476         do jj=1,num_conti
8477           j=jcont_hb(jj,i)
8478 #ifdef MOMENT
8479           call dipole(i,j,jj)
8480 #endif
8481         enddo
8482       enddo
8483       endif
8484 ! Calculate the local-electrostatic correlation terms
8485 !                write (iout,*) "gradcorr5 in eello5 before loop"
8486 !                do iii=1,nres
8487 !                  write (iout,'(i5,3f10.5)')
8488 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8489 !                enddo
8490       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8491 !        write (iout,*) "corr loop i",i
8492         i1=i+1
8493         num_conti=num_cont_hb(i)
8494         num_conti1=num_cont_hb(i+1)
8495         do jj=1,num_conti
8496           j=jcont_hb(jj,i)
8497           jp=iabs(j)
8498           do kk=1,num_conti1
8499             j1=jcont_hb(kk,i1)
8500             jp1=iabs(j1)
8501 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8502 !     &         ' jj=',jj,' kk=',kk
8503 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8504             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8505                 .or. j.lt.0 .and. j1.gt.0) .and. &
8506                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8507 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8508 ! The system gains extra energy.
8509               n_corr=n_corr+1
8510               sqd1=dsqrt(d_cont(jj,i))
8511               sqd2=dsqrt(d_cont(kk,i1))
8512               sred_geom = sqd1*sqd2
8513               IF (sred_geom.lt.cutoff_corr) THEN
8514                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8515                   ekont,fprimcont)
8516 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8517 !d     &         ' jj=',jj,' kk=',kk
8518                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8519                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8520                 do l=1,3
8521                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8522                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8523                 enddo
8524                 n_corr1=n_corr1+1
8525 !d               write (iout,*) 'sred_geom=',sred_geom,
8526 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8527 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8528 !d               write (iout,*) "g_contij",g_contij
8529 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8530 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8531                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8532                 if (wcorr4.gt.0.0d0) &
8533                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8534                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8535                        write (iout,'(a6,4i5,0pf7.3)') &
8536                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8537 !                write (iout,*) "gradcorr5 before eello5"
8538 !                do iii=1,nres
8539 !                  write (iout,'(i5,3f10.5)')
8540 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8541 !                enddo
8542                 if (wcorr5.gt.0.0d0) &
8543                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8544 !                write (iout,*) "gradcorr5 after eello5"
8545 !                do iii=1,nres
8546 !                  write (iout,'(i5,3f10.5)')
8547 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8548 !                enddo
8549                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8550                        write (iout,'(a6,4i5,0pf7.3)') &
8551                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8552 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8553 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8554                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8555                      .or. wturn6.eq.0.0d0))then
8556 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8557                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8558                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8559                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8560 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8561 !d     &            'ecorr6=',ecorr6
8562 !d                write (iout,'(4e15.5)') sred_geom,
8563 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8564 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8565 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8566                 else if (wturn6.gt.0.0d0 &
8567                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8568 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8569                   eturn6=eturn6+eello_turn6(i,jj,kk)
8570                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8571                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8572 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8573                 endif
8574               ENDIF
8575 1111          continue
8576             endif
8577           enddo ! kk
8578         enddo ! jj
8579       enddo ! i
8580       do i=1,nres
8581         num_cont_hb(i)=num_cont_hb_old(i)
8582       enddo
8583 !                write (iout,*) "gradcorr5 in eello5"
8584 !                do iii=1,nres
8585 !                  write (iout,'(i5,3f10.5)')
8586 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8587 !                enddo
8588       return
8589       end subroutine multibody_eello
8590 !-----------------------------------------------------------------------------
8591       subroutine add_hb_contact_eello(ii,jj,itask)
8592 !      implicit real*8 (a-h,o-z)
8593 !      include "DIMENSIONS"
8594 !      include "COMMON.IOUNITS"
8595 !      include "COMMON.CONTACTS"
8596 !      integer,parameter :: maxconts=nres/4
8597       integer,parameter :: max_dim=70
8598       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8599 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8600 !      common /przechowalnia/ zapas
8601
8602       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8603       integer,dimension(4) ::itask
8604 !      write (iout,*) "itask",itask
8605       do i=1,2
8606         iproc=itask(i)
8607         if (iproc.gt.0) then
8608           do j=1,num_cont_hb(ii)
8609             jjc=jcont_hb(j,ii)
8610 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8611             if (jjc.eq.jj) then
8612               ncont_sent(iproc)=ncont_sent(iproc)+1
8613               nn=ncont_sent(iproc)
8614               zapas(1,nn,iproc)=ii
8615               zapas(2,nn,iproc)=jjc
8616               zapas(3,nn,iproc)=d_cont(j,ii)
8617               ind=3
8618               do kk=1,3
8619                 ind=ind+1
8620                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8621               enddo
8622               do kk=1,2
8623                 do ll=1,2
8624                   ind=ind+1
8625                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8626                 enddo
8627               enddo
8628               do jj=1,5
8629                 do kk=1,3
8630                   do ll=1,2
8631                     do mm=1,2
8632                       ind=ind+1
8633                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8634                     enddo
8635                   enddo
8636                 enddo
8637               enddo
8638               exit
8639             endif
8640           enddo
8641         endif
8642       enddo
8643       return
8644       end subroutine add_hb_contact_eello
8645 !-----------------------------------------------------------------------------
8646       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8647 !      implicit real*8 (a-h,o-z)
8648 !      include 'DIMENSIONS'
8649 !      include 'COMMON.IOUNITS'
8650 !      include 'COMMON.DERIV'
8651 !      include 'COMMON.INTERACT'
8652 !      include 'COMMON.CONTACTS'
8653       real(kind=8),dimension(3) :: gx,gx1
8654       logical :: lprn
8655 !el local variables
8656       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8657       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8658                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8659                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8660                    rlocshield
8661
8662       lprn=.false.
8663       eij=facont_hb(jj,i)
8664       ekl=facont_hb(kk,k)
8665       ees0pij=ees0p(jj,i)
8666       ees0pkl=ees0p(kk,k)
8667       ees0mij=ees0m(jj,i)
8668       ees0mkl=ees0m(kk,k)
8669       ekont=eij*ekl
8670       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8671 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8672 ! Following 4 lines for diagnostics.
8673 !d    ees0pkl=0.0D0
8674 !d    ees0pij=1.0D0
8675 !d    ees0mkl=0.0D0
8676 !d    ees0mij=1.0D0
8677 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8678 !     & 'Contacts ',i,j,
8679 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8680 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8681 !     & 'gradcorr_long'
8682 ! Calculate the multi-body contribution to energy.
8683 !      ecorr=ecorr+ekont*ees
8684 ! Calculate multi-body contributions to the gradient.
8685       coeffpees0pij=coeffp*ees0pij
8686       coeffmees0mij=coeffm*ees0mij
8687       coeffpees0pkl=coeffp*ees0pkl
8688       coeffmees0mkl=coeffm*ees0mkl
8689       do ll=1,3
8690 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8691         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8692         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8693         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8694         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8695         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8696         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8697 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8698         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8699         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8700         coeffmees0mij*gacontm_hb1(ll,kk,k))
8701         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8702         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8703         coeffmees0mij*gacontm_hb2(ll,kk,k))
8704         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8705            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8706            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8707         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8708         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8709         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8710            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8711            coeffmees0mij*gacontm_hb3(ll,kk,k))
8712         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8713         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8714 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8715       enddo
8716 !      write (iout,*)
8717 !grad      do m=i+1,j-1
8718 !grad        do ll=1,3
8719 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8720 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8721 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8722 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8723 !grad        enddo
8724 !grad      enddo
8725 !grad      do m=k+1,l-1
8726 !grad        do ll=1,3
8727 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8728 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8729 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8730 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8731 !grad        enddo
8732 !grad      enddo
8733 !      write (iout,*) "ehbcorr",ekont*ees
8734       ehbcorr=ekont*ees
8735       if (shield_mode.gt.0) then
8736        j=ees0plist(jj,i)
8737        l=ees0plist(kk,k)
8738 !C        print *,i,j,fac_shield(i),fac_shield(j),
8739 !C     &fac_shield(k),fac_shield(l)
8740         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8741            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8742           do ilist=1,ishield_list(i)
8743            iresshield=shield_list(ilist,i)
8744            do m=1,3
8745            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8746            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8747                    rlocshield  &
8748             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8749             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8750             +rlocshield
8751            enddo
8752           enddo
8753           do ilist=1,ishield_list(j)
8754            iresshield=shield_list(ilist,j)
8755            do m=1,3
8756            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8757            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8758                    rlocshield &
8759             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8760            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8761             +rlocshield
8762            enddo
8763           enddo
8764
8765           do ilist=1,ishield_list(k)
8766            iresshield=shield_list(ilist,k)
8767            do m=1,3
8768            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8769            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8770                    rlocshield &
8771             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8772            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8773             +rlocshield
8774            enddo
8775           enddo
8776           do ilist=1,ishield_list(l)
8777            iresshield=shield_list(ilist,l)
8778            do m=1,3
8779            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8780            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8781                    rlocshield &
8782             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8783            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8784             +rlocshield
8785            enddo
8786           enddo
8787           do m=1,3
8788             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8789                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8790             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8791                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8792             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8793                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8794             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8795                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8796
8797             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8798                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8799             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8800                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8801             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8802                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8803             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8804                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8805
8806            enddo
8807       endif
8808       endif
8809       return
8810       end function ehbcorr
8811 #ifdef MOMENT
8812 !-----------------------------------------------------------------------------
8813       subroutine dipole(i,j,jj)
8814 !      implicit real*8 (a-h,o-z)
8815 !      include 'DIMENSIONS'
8816 !      include 'COMMON.IOUNITS'
8817 !      include 'COMMON.CHAIN'
8818 !      include 'COMMON.FFIELD'
8819 !      include 'COMMON.DERIV'
8820 !      include 'COMMON.INTERACT'
8821 !      include 'COMMON.CONTACTS'
8822 !      include 'COMMON.TORSION'
8823 !      include 'COMMON.VAR'
8824 !      include 'COMMON.GEO'
8825       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8826       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8827       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8828
8829       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8830       allocate(dipderx(3,5,4,maxconts,nres))
8831 !
8832
8833       iti1 = itortyp(itype(i+1,1))
8834       if (j.lt.nres-1) then
8835         itj1 = itype2loc(itype(j+1,1))
8836       else
8837         itj1=nloctyp
8838       endif
8839       do iii=1,2
8840         dipi(iii,1)=Ub2(iii,i)
8841         dipderi(iii)=Ub2der(iii,i)
8842         dipi(iii,2)=b1(iii,iti1)
8843         dipj(iii,1)=Ub2(iii,j)
8844         dipderj(iii)=Ub2der(iii,j)
8845         dipj(iii,2)=b1(iii,itj1)
8846       enddo
8847       kkk=0
8848       do iii=1,2
8849         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8850         do jjj=1,2
8851           kkk=kkk+1
8852           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8853         enddo
8854       enddo
8855       do kkk=1,5
8856         do lll=1,3
8857           mmm=0
8858           do iii=1,2
8859             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8860               auxvec(1))
8861             do jjj=1,2
8862               mmm=mmm+1
8863               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8864             enddo
8865           enddo
8866         enddo
8867       enddo
8868       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8869       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8870       do iii=1,2
8871         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8872       enddo
8873       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8874       do iii=1,2
8875         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8876       enddo
8877       return
8878       end subroutine dipole
8879 #endif
8880 !-----------------------------------------------------------------------------
8881       subroutine calc_eello(i,j,k,l,jj,kk)
8882 !
8883 ! This subroutine computes matrices and vectors needed to calculate
8884 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8885 !
8886       use comm_kut
8887 !      implicit real*8 (a-h,o-z)
8888 !      include 'DIMENSIONS'
8889 !      include 'COMMON.IOUNITS'
8890 !      include 'COMMON.CHAIN'
8891 !      include 'COMMON.DERIV'
8892 !      include 'COMMON.INTERACT'
8893 !      include 'COMMON.CONTACTS'
8894 !      include 'COMMON.TORSION'
8895 !      include 'COMMON.VAR'
8896 !      include 'COMMON.GEO'
8897 !      include 'COMMON.FFIELD'
8898       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8899       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8900       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8901               itj1
8902 !el      logical :: lprn
8903 !el      common /kutas/ lprn
8904 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8905 !d     & ' jj=',jj,' kk=',kk
8906 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8907 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8908 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8909       do iii=1,2
8910         do jjj=1,2
8911           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8912           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8913         enddo
8914       enddo
8915       call transpose2(aa1(1,1),aa1t(1,1))
8916       call transpose2(aa2(1,1),aa2t(1,1))
8917       do kkk=1,5
8918         do lll=1,3
8919           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8920             aa1tder(1,1,lll,kkk))
8921           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8922             aa2tder(1,1,lll,kkk))
8923         enddo
8924       enddo
8925       if (l.eq.j+1) then
8926 ! parallel orientation of the two CA-CA-CA frames.
8927         if (i.gt.1) then
8928           iti=itortyp(itype(i,1))
8929         else
8930           iti=ntortyp+1
8931         endif
8932         itk1=itortyp(itype(k+1,1))
8933         itj=itortyp(itype(j,1))
8934         if (l.lt.nres-1) then
8935           itl1=itortyp(itype(l+1,1))
8936         else
8937           itl1=ntortyp+1
8938         endif
8939 ! A1 kernel(j+1) A2T
8940 !d        do iii=1,2
8941 !d          write (iout,'(3f10.5,5x,3f10.5)')
8942 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8943 !d        enddo
8944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8945          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8946          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8947 ! Following matrices are needed only for 6-th order cumulants
8948         IF (wcorr6.gt.0.0d0) THEN
8949         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8950          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8951          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8952         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8953          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8954          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8955          ADtEAderx(1,1,1,1,1,1))
8956         lprn=.false.
8957         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8958          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8959          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8960          ADtEA1derx(1,1,1,1,1,1))
8961         ENDIF
8962 ! End 6-th order cumulants
8963 !d        lprn=.false.
8964 !d        if (lprn) then
8965 !d        write (2,*) 'In calc_eello6'
8966 !d        do iii=1,2
8967 !d          write (2,*) 'iii=',iii
8968 !d          do kkk=1,5
8969 !d            write (2,*) 'kkk=',kkk
8970 !d            do jjj=1,2
8971 !d              write (2,'(3(2f10.5),5x)')
8972 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8973 !d            enddo
8974 !d          enddo
8975 !d        enddo
8976 !d        endif
8977         call transpose2(EUgder(1,1,k),auxmat(1,1))
8978         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8979         call transpose2(EUg(1,1,k),auxmat(1,1))
8980         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8981         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8982         do iii=1,2
8983           do kkk=1,5
8984             do lll=1,3
8985               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8986                 EAEAderx(1,1,lll,kkk,iii,1))
8987             enddo
8988           enddo
8989         enddo
8990 ! A1T kernel(i+1) A2
8991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8992          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8993          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8994 ! Following matrices are needed only for 6-th order cumulants
8995         IF (wcorr6.gt.0.0d0) THEN
8996         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8997          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8998          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8999         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9000          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9001          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9002          ADtEAderx(1,1,1,1,1,2))
9003         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9004          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9005          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9006          ADtEA1derx(1,1,1,1,1,2))
9007         ENDIF
9008 ! End 6-th order cumulants
9009         call transpose2(EUgder(1,1,l),auxmat(1,1))
9010         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9011         call transpose2(EUg(1,1,l),auxmat(1,1))
9012         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9013         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9014         do iii=1,2
9015           do kkk=1,5
9016             do lll=1,3
9017               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9018                 EAEAderx(1,1,lll,kkk,iii,2))
9019             enddo
9020           enddo
9021         enddo
9022 ! AEAb1 and AEAb2
9023 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9024 ! They are needed only when the fifth- or the sixth-order cumulants are
9025 ! indluded.
9026         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9027         call transpose2(AEA(1,1,1),auxmat(1,1))
9028         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9029         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9030         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9031         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9032         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9033         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9034         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9035         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9036         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9037         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9038         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9039         call transpose2(AEA(1,1,2),auxmat(1,1))
9040         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9041         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9042         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9043         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9044         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9045         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9046         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9047         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9048         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9049         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9050         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9051 ! Calculate the Cartesian derivatives of the vectors.
9052         do iii=1,2
9053           do kkk=1,5
9054             do lll=1,3
9055               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9056               call matvec2(auxmat(1,1),b1(1,iti),&
9057                 AEAb1derx(1,lll,kkk,iii,1,1))
9058               call matvec2(auxmat(1,1),Ub2(1,i),&
9059                 AEAb2derx(1,lll,kkk,iii,1,1))
9060               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9061                 AEAb1derx(1,lll,kkk,iii,2,1))
9062               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9063                 AEAb2derx(1,lll,kkk,iii,2,1))
9064               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9065               call matvec2(auxmat(1,1),b1(1,itj),&
9066                 AEAb1derx(1,lll,kkk,iii,1,2))
9067               call matvec2(auxmat(1,1),Ub2(1,j),&
9068                 AEAb2derx(1,lll,kkk,iii,1,2))
9069               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9070                 AEAb1derx(1,lll,kkk,iii,2,2))
9071               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9072                 AEAb2derx(1,lll,kkk,iii,2,2))
9073             enddo
9074           enddo
9075         enddo
9076         ENDIF
9077 ! End vectors
9078       else
9079 ! Antiparallel orientation of the two CA-CA-CA frames.
9080         if (i.gt.1) then
9081           iti=itortyp(itype(i,1))
9082         else
9083           iti=ntortyp+1
9084         endif
9085         itk1=itortyp(itype(k+1,1))
9086         itl=itortyp(itype(l,1))
9087         itj=itortyp(itype(j,1))
9088         if (j.lt.nres-1) then
9089           itj1=itortyp(itype(j+1,1))
9090         else
9091           itj1=ntortyp+1
9092         endif
9093 ! A2 kernel(j-1)T A1T
9094         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9095          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9096          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9097 ! Following matrices are needed only for 6-th order cumulants
9098         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9099            j.eq.i+4 .and. l.eq.i+3)) THEN
9100         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9101          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9102          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9103         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9104          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9105          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9106          ADtEAderx(1,1,1,1,1,1))
9107         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9108          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9109          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9110          ADtEA1derx(1,1,1,1,1,1))
9111         ENDIF
9112 ! End 6-th order cumulants
9113         call transpose2(EUgder(1,1,k),auxmat(1,1))
9114         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9115         call transpose2(EUg(1,1,k),auxmat(1,1))
9116         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9117         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9118         do iii=1,2
9119           do kkk=1,5
9120             do lll=1,3
9121               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9122                 EAEAderx(1,1,lll,kkk,iii,1))
9123             enddo
9124           enddo
9125         enddo
9126 ! A2T kernel(i+1)T A1
9127         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9128          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9129          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9130 ! Following matrices are needed only for 6-th order cumulants
9131         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9132            j.eq.i+4 .and. l.eq.i+3)) THEN
9133         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9134          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9135          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9136         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9137          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9138          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9139          ADtEAderx(1,1,1,1,1,2))
9140         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9141          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9142          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9143          ADtEA1derx(1,1,1,1,1,2))
9144         ENDIF
9145 ! End 6-th order cumulants
9146         call transpose2(EUgder(1,1,j),auxmat(1,1))
9147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9148         call transpose2(EUg(1,1,j),auxmat(1,1))
9149         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9150         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9151         do iii=1,2
9152           do kkk=1,5
9153             do lll=1,3
9154               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9155                 EAEAderx(1,1,lll,kkk,iii,2))
9156             enddo
9157           enddo
9158         enddo
9159 ! AEAb1 and AEAb2
9160 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9161 ! They are needed only when the fifth- or the sixth-order cumulants are
9162 ! indluded.
9163         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9164           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9165         call transpose2(AEA(1,1,1),auxmat(1,1))
9166         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9168         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9169         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9170         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9171         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9172         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9173         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9174         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9175         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9176         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9177         call transpose2(AEA(1,1,2),auxmat(1,1))
9178         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9179         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9180         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9181         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9182         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9183         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9184         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9185         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9186         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9187         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9188         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9189 ! Calculate the Cartesian derivatives of the vectors.
9190         do iii=1,2
9191           do kkk=1,5
9192             do lll=1,3
9193               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9194               call matvec2(auxmat(1,1),b1(1,iti),&
9195                 AEAb1derx(1,lll,kkk,iii,1,1))
9196               call matvec2(auxmat(1,1),Ub2(1,i),&
9197                 AEAb2derx(1,lll,kkk,iii,1,1))
9198               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9199                 AEAb1derx(1,lll,kkk,iii,2,1))
9200               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9201                 AEAb2derx(1,lll,kkk,iii,2,1))
9202               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9203               call matvec2(auxmat(1,1),b1(1,itl),&
9204                 AEAb1derx(1,lll,kkk,iii,1,2))
9205               call matvec2(auxmat(1,1),Ub2(1,l),&
9206                 AEAb2derx(1,lll,kkk,iii,1,2))
9207               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9208                 AEAb1derx(1,lll,kkk,iii,2,2))
9209               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9210                 AEAb2derx(1,lll,kkk,iii,2,2))
9211             enddo
9212           enddo
9213         enddo
9214         ENDIF
9215 ! End vectors
9216       endif
9217       return
9218       end subroutine calc_eello
9219 !-----------------------------------------------------------------------------
9220       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9221       use comm_kut
9222       implicit none
9223       integer :: nderg
9224       logical :: transp
9225       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9226       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9227       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9228       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9229       integer :: iii,kkk,lll
9230       integer :: jjj,mmm
9231 !el      logical :: lprn
9232 !el      common /kutas/ lprn
9233       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9234       do iii=1,nderg
9235         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9236           AKAderg(1,1,iii))
9237       enddo
9238 !d      if (lprn) write (2,*) 'In kernel'
9239       do kkk=1,5
9240 !d        if (lprn) write (2,*) 'kkk=',kkk
9241         do lll=1,3
9242           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9243             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9244 !d          if (lprn) then
9245 !d            write (2,*) 'lll=',lll
9246 !d            write (2,*) 'iii=1'
9247 !d            do jjj=1,2
9248 !d              write (2,'(3(2f10.5),5x)')
9249 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9250 !d            enddo
9251 !d          endif
9252           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9253             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9254 !d          if (lprn) then
9255 !d            write (2,*) 'lll=',lll
9256 !d            write (2,*) 'iii=2'
9257 !d            do jjj=1,2
9258 !d              write (2,'(3(2f10.5),5x)')
9259 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9260 !d            enddo
9261 !d          endif
9262         enddo
9263       enddo
9264       return
9265       end subroutine kernel
9266 !-----------------------------------------------------------------------------
9267       real(kind=8) function eello4(i,j,k,l,jj,kk)
9268 !      implicit real*8 (a-h,o-z)
9269 !      include 'DIMENSIONS'
9270 !      include 'COMMON.IOUNITS'
9271 !      include 'COMMON.CHAIN'
9272 !      include 'COMMON.DERIV'
9273 !      include 'COMMON.INTERACT'
9274 !      include 'COMMON.CONTACTS'
9275 !      include 'COMMON.TORSION'
9276 !      include 'COMMON.VAR'
9277 !      include 'COMMON.GEO'
9278       real(kind=8),dimension(2,2) :: pizda
9279       real(kind=8),dimension(3) :: ggg1,ggg2
9280       real(kind=8) ::  eel4,glongij,glongkl
9281       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9282 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9283 !d        eello4=0.0d0
9284 !d        return
9285 !d      endif
9286 !d      print *,'eello4:',i,j,k,l,jj,kk
9287 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9288 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9289 !old      eij=facont_hb(jj,i)
9290 !old      ekl=facont_hb(kk,k)
9291 !old      ekont=eij*ekl
9292       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9293 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9294       gcorr_loc(k-1)=gcorr_loc(k-1) &
9295          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9296       if (l.eq.j+1) then
9297         gcorr_loc(l-1)=gcorr_loc(l-1) &
9298            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9299       else
9300         gcorr_loc(j-1)=gcorr_loc(j-1) &
9301            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9302       endif
9303       do iii=1,2
9304         do kkk=1,5
9305           do lll=1,3
9306             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9307                               -EAEAderx(2,2,lll,kkk,iii,1)
9308 !d            derx(lll,kkk,iii)=0.0d0
9309           enddo
9310         enddo
9311       enddo
9312 !d      gcorr_loc(l-1)=0.0d0
9313 !d      gcorr_loc(j-1)=0.0d0
9314 !d      gcorr_loc(k-1)=0.0d0
9315 !d      eel4=1.0d0
9316 !d      write (iout,*)'Contacts have occurred for peptide groups',
9317 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9318 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9319       if (j.lt.nres-1) then
9320         j1=j+1
9321         j2=j-1
9322       else
9323         j1=j-1
9324         j2=j-2
9325       endif
9326       if (l.lt.nres-1) then
9327         l1=l+1
9328         l2=l-1
9329       else
9330         l1=l-1
9331         l2=l-2
9332       endif
9333       do ll=1,3
9334 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9335 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9336         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9337         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9338 !grad        ghalf=0.5d0*ggg1(ll)
9339         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9340         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9341         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9342         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9343         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9344         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9345 !grad        ghalf=0.5d0*ggg2(ll)
9346         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9347         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9348         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9349         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9350         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9351         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9352       enddo
9353 !grad      do m=i+1,j-1
9354 !grad        do ll=1,3
9355 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9356 !grad        enddo
9357 !grad      enddo
9358 !grad      do m=k+1,l-1
9359 !grad        do ll=1,3
9360 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9361 !grad        enddo
9362 !grad      enddo
9363 !grad      do m=i+2,j2
9364 !grad        do ll=1,3
9365 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9366 !grad        enddo
9367 !grad      enddo
9368 !grad      do m=k+2,l2
9369 !grad        do ll=1,3
9370 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9371 !grad        enddo
9372 !grad      enddo
9373 !d      do iii=1,nres-3
9374 !d        write (2,*) iii,gcorr_loc(iii)
9375 !d      enddo
9376       eello4=ekont*eel4
9377 !d      write (2,*) 'ekont',ekont
9378 !d      write (iout,*) 'eello4',ekont*eel4
9379       return
9380       end function eello4
9381 !-----------------------------------------------------------------------------
9382       real(kind=8) function eello5(i,j,k,l,jj,kk)
9383 !      implicit real*8 (a-h,o-z)
9384 !      include 'DIMENSIONS'
9385 !      include 'COMMON.IOUNITS'
9386 !      include 'COMMON.CHAIN'
9387 !      include 'COMMON.DERIV'
9388 !      include 'COMMON.INTERACT'
9389 !      include 'COMMON.CONTACTS'
9390 !      include 'COMMON.TORSION'
9391 !      include 'COMMON.VAR'
9392 !      include 'COMMON.GEO'
9393       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9394       real(kind=8),dimension(2) :: vv
9395       real(kind=8),dimension(3) :: ggg1,ggg2
9396       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9397       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9398       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9399 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9400 !                                                                              C
9401 !                            Parallel chains                                   C
9402 !                                                                              C
9403 !          o             o                   o             o                   C
9404 !         /l\           / \             \   / \           / \   /              C
9405 !        /   \         /   \             \ /   \         /   \ /               C
9406 !       j| o |l1       | o |                o| o |         | o |o                C
9407 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9408 !      \i/   \         /   \ /             /   \         /   \                 C
9409 !       o    k1             o                                                  C
9410 !         (I)          (II)                (III)          (IV)                 C
9411 !                                                                              C
9412 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9413 !                                                                              C
9414 !                            Antiparallel chains                               C
9415 !                                                                              C
9416 !          o             o                   o             o                   C
9417 !         /j\           / \             \   / \           / \   /              C
9418 !        /   \         /   \             \ /   \         /   \ /               C
9419 !      j1| o |l        | o |                o| o |         | o |o                C
9420 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9421 !      \i/   \         /   \ /             /   \         /   \                 C
9422 !       o     k1            o                                                  C
9423 !         (I)          (II)                (III)          (IV)                 C
9424 !                                                                              C
9425 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9426 !                                                                              C
9427 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9428 !                                                                              C
9429 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9430 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9431 !d        eello5=0.0d0
9432 !d        return
9433 !d      endif
9434 !d      write (iout,*)
9435 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9436 !d     &   ' and',k,l
9437       itk=itortyp(itype(k,1))
9438       itl=itortyp(itype(l,1))
9439       itj=itortyp(itype(j,1))
9440       eello5_1=0.0d0
9441       eello5_2=0.0d0
9442       eello5_3=0.0d0
9443       eello5_4=0.0d0
9444 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9445 !d     &   eel5_3_num,eel5_4_num)
9446       do iii=1,2
9447         do kkk=1,5
9448           do lll=1,3
9449             derx(lll,kkk,iii)=0.0d0
9450           enddo
9451         enddo
9452       enddo
9453 !d      eij=facont_hb(jj,i)
9454 !d      ekl=facont_hb(kk,k)
9455 !d      ekont=eij*ekl
9456 !d      write (iout,*)'Contacts have occurred for peptide groups',
9457 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9458 !d      goto 1111
9459 ! Contribution from the graph I.
9460 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9461 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9462       call transpose2(EUg(1,1,k),auxmat(1,1))
9463       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9464       vv(1)=pizda(1,1)-pizda(2,2)
9465       vv(2)=pizda(1,2)+pizda(2,1)
9466       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9467        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9468 ! Explicit gradient in virtual-dihedral angles.
9469       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9470        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9471        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9472       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9473       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9474       vv(1)=pizda(1,1)-pizda(2,2)
9475       vv(2)=pizda(1,2)+pizda(2,1)
9476       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9477        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9478        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9479       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9480       vv(1)=pizda(1,1)-pizda(2,2)
9481       vv(2)=pizda(1,2)+pizda(2,1)
9482       if (l.eq.j+1) then
9483         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9484          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9485          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9486       else
9487         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9488          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9489          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9490       endif
9491 ! Cartesian gradient
9492       do iii=1,2
9493         do kkk=1,5
9494           do lll=1,3
9495             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9496               pizda(1,1))
9497             vv(1)=pizda(1,1)-pizda(2,2)
9498             vv(2)=pizda(1,2)+pizda(2,1)
9499             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9500              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9501              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9502           enddo
9503         enddo
9504       enddo
9505 !      goto 1112
9506 !1111  continue
9507 ! Contribution from graph II
9508       call transpose2(EE(1,1,itk),auxmat(1,1))
9509       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9510       vv(1)=pizda(1,1)+pizda(2,2)
9511       vv(2)=pizda(2,1)-pizda(1,2)
9512       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9513        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9514 ! Explicit gradient in virtual-dihedral angles.
9515       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9516        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9517       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9518       vv(1)=pizda(1,1)+pizda(2,2)
9519       vv(2)=pizda(2,1)-pizda(1,2)
9520       if (l.eq.j+1) then
9521         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9522          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9523          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9524       else
9525         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9526          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9527          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9528       endif
9529 ! Cartesian gradient
9530       do iii=1,2
9531         do kkk=1,5
9532           do lll=1,3
9533             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9534               pizda(1,1))
9535             vv(1)=pizda(1,1)+pizda(2,2)
9536             vv(2)=pizda(2,1)-pizda(1,2)
9537             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9538              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9539              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9540           enddo
9541         enddo
9542       enddo
9543 !d      goto 1112
9544 !d1111  continue
9545       if (l.eq.j+1) then
9546 !d        goto 1110
9547 ! Parallel orientation
9548 ! Contribution from graph III
9549         call transpose2(EUg(1,1,l),auxmat(1,1))
9550         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9551         vv(1)=pizda(1,1)-pizda(2,2)
9552         vv(2)=pizda(1,2)+pizda(2,1)
9553         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9554          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9555 ! Explicit gradient in virtual-dihedral angles.
9556         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9557          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9558          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9559         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9560         vv(1)=pizda(1,1)-pizda(2,2)
9561         vv(2)=pizda(1,2)+pizda(2,1)
9562         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9563          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9564          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9565         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9566         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9567         vv(1)=pizda(1,1)-pizda(2,2)
9568         vv(2)=pizda(1,2)+pizda(2,1)
9569         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9570          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9571          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9572 ! Cartesian gradient
9573         do iii=1,2
9574           do kkk=1,5
9575             do lll=1,3
9576               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9577                 pizda(1,1))
9578               vv(1)=pizda(1,1)-pizda(2,2)
9579               vv(2)=pizda(1,2)+pizda(2,1)
9580               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9581                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9582                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9583             enddo
9584           enddo
9585         enddo
9586 !d        goto 1112
9587 ! Contribution from graph IV
9588 !d1110    continue
9589         call transpose2(EE(1,1,itl),auxmat(1,1))
9590         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9591         vv(1)=pizda(1,1)+pizda(2,2)
9592         vv(2)=pizda(2,1)-pizda(1,2)
9593         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9594          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9595 ! Explicit gradient in virtual-dihedral angles.
9596         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9597          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9598         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9599         vv(1)=pizda(1,1)+pizda(2,2)
9600         vv(2)=pizda(2,1)-pizda(1,2)
9601         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9602          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9603          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9604 ! Cartesian gradient
9605         do iii=1,2
9606           do kkk=1,5
9607             do lll=1,3
9608               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9609                 pizda(1,1))
9610               vv(1)=pizda(1,1)+pizda(2,2)
9611               vv(2)=pizda(2,1)-pizda(1,2)
9612               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9613                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9614                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9615             enddo
9616           enddo
9617         enddo
9618       else
9619 ! Antiparallel orientation
9620 ! Contribution from graph III
9621 !        goto 1110
9622         call transpose2(EUg(1,1,j),auxmat(1,1))
9623         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9624         vv(1)=pizda(1,1)-pizda(2,2)
9625         vv(2)=pizda(1,2)+pizda(2,1)
9626         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9627          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9628 ! Explicit gradient in virtual-dihedral angles.
9629         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9630          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9631          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9632         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9633         vv(1)=pizda(1,1)-pizda(2,2)
9634         vv(2)=pizda(1,2)+pizda(2,1)
9635         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9636          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9637          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9638         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9639         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9640         vv(1)=pizda(1,1)-pizda(2,2)
9641         vv(2)=pizda(1,2)+pizda(2,1)
9642         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9643          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9644          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9645 ! Cartesian gradient
9646         do iii=1,2
9647           do kkk=1,5
9648             do lll=1,3
9649               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9650                 pizda(1,1))
9651               vv(1)=pizda(1,1)-pizda(2,2)
9652               vv(2)=pizda(1,2)+pizda(2,1)
9653               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9654                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9655                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9656             enddo
9657           enddo
9658         enddo
9659 !d        goto 1112
9660 ! Contribution from graph IV
9661 1110    continue
9662         call transpose2(EE(1,1,itj),auxmat(1,1))
9663         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9664         vv(1)=pizda(1,1)+pizda(2,2)
9665         vv(2)=pizda(2,1)-pizda(1,2)
9666         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9667          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9668 ! Explicit gradient in virtual-dihedral angles.
9669         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9670          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9671         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9672         vv(1)=pizda(1,1)+pizda(2,2)
9673         vv(2)=pizda(2,1)-pizda(1,2)
9674         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9675          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9676          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9677 ! Cartesian gradient
9678         do iii=1,2
9679           do kkk=1,5
9680             do lll=1,3
9681               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9682                 pizda(1,1))
9683               vv(1)=pizda(1,1)+pizda(2,2)
9684               vv(2)=pizda(2,1)-pizda(1,2)
9685               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9686                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9687                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9688             enddo
9689           enddo
9690         enddo
9691       endif
9692 1112  continue
9693       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9694 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9695 !d        write (2,*) 'ijkl',i,j,k,l
9696 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9697 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9698 !d      endif
9699 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9700 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9701 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9702 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9703       if (j.lt.nres-1) then
9704         j1=j+1
9705         j2=j-1
9706       else
9707         j1=j-1
9708         j2=j-2
9709       endif
9710       if (l.lt.nres-1) then
9711         l1=l+1
9712         l2=l-1
9713       else
9714         l1=l-1
9715         l2=l-2
9716       endif
9717 !d      eij=1.0d0
9718 !d      ekl=1.0d0
9719 !d      ekont=1.0d0
9720 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9721 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9722 !        summed up outside the subrouine as for the other subroutines
9723 !        handling long-range interactions. The old code is commented out
9724 !        with "cgrad" to keep track of changes.
9725       do ll=1,3
9726 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9727 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9728         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9729         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9730 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9731 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9732 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9733 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9734 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9735 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9736 !     &   gradcorr5ij,
9737 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9738 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9739 !grad        ghalf=0.5d0*ggg1(ll)
9740 !d        ghalf=0.0d0
9741         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9742         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9743         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9744         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9745         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9746         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9747 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9748 !grad        ghalf=0.5d0*ggg2(ll)
9749         ghalf=0.0d0
9750         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9751         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9752         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9753         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9754         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9755         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9756       enddo
9757 !d      goto 1112
9758 !grad      do m=i+1,j-1
9759 !grad        do ll=1,3
9760 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9761 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9762 !grad        enddo
9763 !grad      enddo
9764 !grad      do m=k+1,l-1
9765 !grad        do ll=1,3
9766 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9767 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9768 !grad        enddo
9769 !grad      enddo
9770 !1112  continue
9771 !grad      do m=i+2,j2
9772 !grad        do ll=1,3
9773 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9774 !grad        enddo
9775 !grad      enddo
9776 !grad      do m=k+2,l2
9777 !grad        do ll=1,3
9778 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9779 !grad        enddo
9780 !grad      enddo
9781 !d      do iii=1,nres-3
9782 !d        write (2,*) iii,g_corr5_loc(iii)
9783 !d      enddo
9784       eello5=ekont*eel5
9785 !d      write (2,*) 'ekont',ekont
9786 !d      write (iout,*) 'eello5',ekont*eel5
9787       return
9788       end function eello5
9789 !-----------------------------------------------------------------------------
9790       real(kind=8) function eello6(i,j,k,l,jj,kk)
9791 !      implicit real*8 (a-h,o-z)
9792 !      include 'DIMENSIONS'
9793 !      include 'COMMON.IOUNITS'
9794 !      include 'COMMON.CHAIN'
9795 !      include 'COMMON.DERIV'
9796 !      include 'COMMON.INTERACT'
9797 !      include 'COMMON.CONTACTS'
9798 !      include 'COMMON.TORSION'
9799 !      include 'COMMON.VAR'
9800 !      include 'COMMON.GEO'
9801 !      include 'COMMON.FFIELD'
9802       real(kind=8),dimension(3) :: ggg1,ggg2
9803       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9804                    eello6_6,eel6
9805       real(kind=8) :: gradcorr6ij,gradcorr6kl
9806       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9807 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9808 !d        eello6=0.0d0
9809 !d        return
9810 !d      endif
9811 !d      write (iout,*)
9812 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9813 !d     &   ' and',k,l
9814       eello6_1=0.0d0
9815       eello6_2=0.0d0
9816       eello6_3=0.0d0
9817       eello6_4=0.0d0
9818       eello6_5=0.0d0
9819       eello6_6=0.0d0
9820 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9821 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9822       do iii=1,2
9823         do kkk=1,5
9824           do lll=1,3
9825             derx(lll,kkk,iii)=0.0d0
9826           enddo
9827         enddo
9828       enddo
9829 !d      eij=facont_hb(jj,i)
9830 !d      ekl=facont_hb(kk,k)
9831 !d      ekont=eij*ekl
9832 !d      eij=1.0d0
9833 !d      ekl=1.0d0
9834 !d      ekont=1.0d0
9835       if (l.eq.j+1) then
9836         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9837         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9838         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9839         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9840         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9841         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9842       else
9843         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9844         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9845         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9846         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9847         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9848           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9849         else
9850           eello6_5=0.0d0
9851         endif
9852         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9853       endif
9854 ! If turn contributions are considered, they will be handled separately.
9855       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9856 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9857 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9858 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9859 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9860 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9861 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9862 !d      goto 1112
9863       if (j.lt.nres-1) then
9864         j1=j+1
9865         j2=j-1
9866       else
9867         j1=j-1
9868         j2=j-2
9869       endif
9870       if (l.lt.nres-1) then
9871         l1=l+1
9872         l2=l-1
9873       else
9874         l1=l-1
9875         l2=l-2
9876       endif
9877       do ll=1,3
9878 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9879 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9880 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9881 !grad        ghalf=0.5d0*ggg1(ll)
9882 !d        ghalf=0.0d0
9883         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9884         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9885         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9886         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9887         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9888         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9889         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9890         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9891 !grad        ghalf=0.5d0*ggg2(ll)
9892 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9893 !d        ghalf=0.0d0
9894         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9895         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9896         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9897         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9898         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9899         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9900       enddo
9901 !d      goto 1112
9902 !grad      do m=i+1,j-1
9903 !grad        do ll=1,3
9904 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9905 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9906 !grad        enddo
9907 !grad      enddo
9908 !grad      do m=k+1,l-1
9909 !grad        do ll=1,3
9910 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9911 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9912 !grad        enddo
9913 !grad      enddo
9914 !grad1112  continue
9915 !grad      do m=i+2,j2
9916 !grad        do ll=1,3
9917 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9918 !grad        enddo
9919 !grad      enddo
9920 !grad      do m=k+2,l2
9921 !grad        do ll=1,3
9922 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9923 !grad        enddo
9924 !grad      enddo
9925 !d      do iii=1,nres-3
9926 !d        write (2,*) iii,g_corr6_loc(iii)
9927 !d      enddo
9928       eello6=ekont*eel6
9929 !d      write (2,*) 'ekont',ekont
9930 !d      write (iout,*) 'eello6',ekont*eel6
9931       return
9932       end function eello6
9933 !-----------------------------------------------------------------------------
9934       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9935       use comm_kut
9936 !      implicit real*8 (a-h,o-z)
9937 !      include 'DIMENSIONS'
9938 !      include 'COMMON.IOUNITS'
9939 !      include 'COMMON.CHAIN'
9940 !      include 'COMMON.DERIV'
9941 !      include 'COMMON.INTERACT'
9942 !      include 'COMMON.CONTACTS'
9943 !      include 'COMMON.TORSION'
9944 !      include 'COMMON.VAR'
9945 !      include 'COMMON.GEO'
9946       real(kind=8),dimension(2) :: vv,vv1
9947       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9948       logical :: swap
9949 !el      logical :: lprn
9950 !el      common /kutas/ lprn
9951       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9952       real(kind=8) :: s1,s2,s3,s4,s5
9953 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9954 !                                                                              C
9955 !      Parallel       Antiparallel                                             C
9956 !                                                                              C
9957 !          o             o                                                     C
9958 !         /l\           /j\                                                    C
9959 !        /   \         /   \                                                   C
9960 !       /| o |         | o |\                                                  C
9961 !     \ j|/k\|  /   \  |/k\|l /                                                C
9962 !      \ /   \ /     \ /   \ /                                                 C
9963 !       o     o       o     o                                                  C
9964 !       i             i                                                        C
9965 !                                                                              C
9966 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9967       itk=itortyp(itype(k,1))
9968       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9969       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9970       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9971       call transpose2(EUgC(1,1,k),auxmat(1,1))
9972       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9973       vv1(1)=pizda1(1,1)-pizda1(2,2)
9974       vv1(2)=pizda1(1,2)+pizda1(2,1)
9975       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9976       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9977       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9978       s5=scalar2(vv(1),Dtobr2(1,i))
9979 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9980       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9981       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9982        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9983        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9984        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9985        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9986        +scalar2(vv(1),Dtobr2der(1,i)))
9987       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9988       vv1(1)=pizda1(1,1)-pizda1(2,2)
9989       vv1(2)=pizda1(1,2)+pizda1(2,1)
9990       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9991       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9992       if (l.eq.j+1) then
9993         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9994        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9995        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9996        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9997        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9998       else
9999         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10000        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10001        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10002        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10003        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10004       endif
10005       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10006       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10007       vv1(1)=pizda1(1,1)-pizda1(2,2)
10008       vv1(2)=pizda1(1,2)+pizda1(2,1)
10009       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10010        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10011        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10012        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10013       do iii=1,2
10014         if (swap) then
10015           ind=3-iii
10016         else
10017           ind=iii
10018         endif
10019         do kkk=1,5
10020           do lll=1,3
10021             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10022             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10023             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10024             call transpose2(EUgC(1,1,k),auxmat(1,1))
10025             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10026               pizda1(1,1))
10027             vv1(1)=pizda1(1,1)-pizda1(2,2)
10028             vv1(2)=pizda1(1,2)+pizda1(2,1)
10029             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10030             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10031              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10032             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10033              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10034             s5=scalar2(vv(1),Dtobr2(1,i))
10035             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10036           enddo
10037         enddo
10038       enddo
10039       return
10040       end function eello6_graph1
10041 !-----------------------------------------------------------------------------
10042       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10043       use comm_kut
10044 !      implicit real*8 (a-h,o-z)
10045 !      include 'DIMENSIONS'
10046 !      include 'COMMON.IOUNITS'
10047 !      include 'COMMON.CHAIN'
10048 !      include 'COMMON.DERIV'
10049 !      include 'COMMON.INTERACT'
10050 !      include 'COMMON.CONTACTS'
10051 !      include 'COMMON.TORSION'
10052 !      include 'COMMON.VAR'
10053 !      include 'COMMON.GEO'
10054       logical :: swap
10055       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10056       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10057 !el      logical :: lprn
10058 !el      common /kutas/ lprn
10059       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10060       real(kind=8) :: s2,s3,s4
10061 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10062 !                                                                              C
10063 !      Parallel       Antiparallel                                             C
10064 !                                                                              C
10065 !          o             o                                                     C
10066 !     \   /l\           /j\   /                                                C
10067 !      \ /   \         /   \ /                                                 C
10068 !       o| o |         | o |o                                                  C
10069 !     \ j|/k\|      \  |/k\|l                                                  C
10070 !      \ /   \       \ /   \                                                   C
10071 !       o             o                                                        C
10072 !       i             i                                                        C
10073 !                                                                              C
10074 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10075 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10076 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10077 !           but not in a cluster cumulant
10078 #ifdef MOMENT
10079       s1=dip(1,jj,i)*dip(1,kk,k)
10080 #endif
10081       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10082       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10083       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10084       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10085       call transpose2(EUg(1,1,k),auxmat(1,1))
10086       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10087       vv(1)=pizda(1,1)-pizda(2,2)
10088       vv(2)=pizda(1,2)+pizda(2,1)
10089       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10090 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10091 #ifdef MOMENT
10092       eello6_graph2=-(s1+s2+s3+s4)
10093 #else
10094       eello6_graph2=-(s2+s3+s4)
10095 #endif
10096 !      eello6_graph2=-s3
10097 ! Derivatives in gamma(i-1)
10098       if (i.gt.1) then
10099 #ifdef MOMENT
10100         s1=dipderg(1,jj,i)*dip(1,kk,k)
10101 #endif
10102         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10103         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10104         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10105         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10106 #ifdef MOMENT
10107         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10108 #else
10109         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10110 #endif
10111 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10112       endif
10113 ! Derivatives in gamma(k-1)
10114 #ifdef MOMENT
10115       s1=dip(1,jj,i)*dipderg(1,kk,k)
10116 #endif
10117       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10118       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10119       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10120       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10121       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10122       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10123       vv(1)=pizda(1,1)-pizda(2,2)
10124       vv(2)=pizda(1,2)+pizda(2,1)
10125       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10126 #ifdef MOMENT
10127       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10128 #else
10129       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10130 #endif
10131 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10132 ! Derivatives in gamma(j-1) or gamma(l-1)
10133       if (j.gt.1) then
10134 #ifdef MOMENT
10135         s1=dipderg(3,jj,i)*dip(1,kk,k)
10136 #endif
10137         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10138         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10139         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10140         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10141         vv(1)=pizda(1,1)-pizda(2,2)
10142         vv(2)=pizda(1,2)+pizda(2,1)
10143         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10144 #ifdef MOMENT
10145         if (swap) then
10146           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10147         else
10148           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10149         endif
10150 #endif
10151         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10152 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10153       endif
10154 ! Derivatives in gamma(l-1) or gamma(j-1)
10155       if (l.gt.1) then
10156 #ifdef MOMENT
10157         s1=dip(1,jj,i)*dipderg(3,kk,k)
10158 #endif
10159         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10160         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10161         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10162         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10163         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10164         vv(1)=pizda(1,1)-pizda(2,2)
10165         vv(2)=pizda(1,2)+pizda(2,1)
10166         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10167 #ifdef MOMENT
10168         if (swap) then
10169           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10170         else
10171           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10172         endif
10173 #endif
10174         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10175 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10176       endif
10177 ! Cartesian derivatives.
10178       if (lprn) then
10179         write (2,*) 'In eello6_graph2'
10180         do iii=1,2
10181           write (2,*) 'iii=',iii
10182           do kkk=1,5
10183             write (2,*) 'kkk=',kkk
10184             do jjj=1,2
10185               write (2,'(3(2f10.5),5x)') &
10186               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10187             enddo
10188           enddo
10189         enddo
10190       endif
10191       do iii=1,2
10192         do kkk=1,5
10193           do lll=1,3
10194 #ifdef MOMENT
10195             if (iii.eq.1) then
10196               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10197             else
10198               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10199             endif
10200 #endif
10201             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10202               auxvec(1))
10203             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10204             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10205               auxvec(1))
10206             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10207             call transpose2(EUg(1,1,k),auxmat(1,1))
10208             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10209               pizda(1,1))
10210             vv(1)=pizda(1,1)-pizda(2,2)
10211             vv(2)=pizda(1,2)+pizda(2,1)
10212             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10213 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10214 #ifdef MOMENT
10215             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10216 #else
10217             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10218 #endif
10219             if (swap) then
10220               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10221             else
10222               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10223             endif
10224           enddo
10225         enddo
10226       enddo
10227       return
10228       end function eello6_graph2
10229 !-----------------------------------------------------------------------------
10230       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10231 !      implicit real*8 (a-h,o-z)
10232 !      include 'DIMENSIONS'
10233 !      include 'COMMON.IOUNITS'
10234 !      include 'COMMON.CHAIN'
10235 !      include 'COMMON.DERIV'
10236 !      include 'COMMON.INTERACT'
10237 !      include 'COMMON.CONTACTS'
10238 !      include 'COMMON.TORSION'
10239 !      include 'COMMON.VAR'
10240 !      include 'COMMON.GEO'
10241       real(kind=8),dimension(2) :: vv,auxvec
10242       real(kind=8),dimension(2,2) :: pizda,auxmat
10243       logical :: swap
10244       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10245       real(kind=8) :: s1,s2,s3,s4
10246 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10247 !                                                                              C
10248 !      Parallel       Antiparallel                                             C
10249 !                                                                              C
10250 !          o             o                                                     C
10251 !         /l\   /   \   /j\                                                    C
10252 !        /   \ /     \ /   \                                                   C
10253 !       /| o |o       o| o |\                                                  C
10254 !       j|/k\|  /      |/k\|l /                                                C
10255 !        /   \ /       /   \ /                                                 C
10256 !       /     o       /     o                                                  C
10257 !       i             i                                                        C
10258 !                                                                              C
10259 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10260 !
10261 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10262 !           energy moment and not to the cluster cumulant.
10263       iti=itortyp(itype(i,1))
10264       if (j.lt.nres-1) then
10265         itj1=itortyp(itype(j+1,1))
10266       else
10267         itj1=ntortyp+1
10268       endif
10269       itk=itortyp(itype(k,1))
10270       itk1=itortyp(itype(k+1,1))
10271       if (l.lt.nres-1) then
10272         itl1=itortyp(itype(l+1,1))
10273       else
10274         itl1=ntortyp+1
10275       endif
10276 #ifdef MOMENT
10277       s1=dip(4,jj,i)*dip(4,kk,k)
10278 #endif
10279       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10280       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10281       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10282       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10283       call transpose2(EE(1,1,itk),auxmat(1,1))
10284       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10285       vv(1)=pizda(1,1)+pizda(2,2)
10286       vv(2)=pizda(2,1)-pizda(1,2)
10287       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10288 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10289 !d     & "sum",-(s2+s3+s4)
10290 #ifdef MOMENT
10291       eello6_graph3=-(s1+s2+s3+s4)
10292 #else
10293       eello6_graph3=-(s2+s3+s4)
10294 #endif
10295 !      eello6_graph3=-s4
10296 ! Derivatives in gamma(k-1)
10297       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10298       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10299       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10300       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10301 ! Derivatives in gamma(l-1)
10302       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10303       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10304       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10305       vv(1)=pizda(1,1)+pizda(2,2)
10306       vv(2)=pizda(2,1)-pizda(1,2)
10307       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10308       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10309 ! Cartesian derivatives.
10310       do iii=1,2
10311         do kkk=1,5
10312           do lll=1,3
10313 #ifdef MOMENT
10314             if (iii.eq.1) then
10315               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10316             else
10317               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10318             endif
10319 #endif
10320             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10321               auxvec(1))
10322             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10323             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10324               auxvec(1))
10325             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10326             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10327               pizda(1,1))
10328             vv(1)=pizda(1,1)+pizda(2,2)
10329             vv(2)=pizda(2,1)-pizda(1,2)
10330             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10331 #ifdef MOMENT
10332             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10333 #else
10334             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10335 #endif
10336             if (swap) then
10337               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10338             else
10339               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10340             endif
10341 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10342           enddo
10343         enddo
10344       enddo
10345       return
10346       end function eello6_graph3
10347 !-----------------------------------------------------------------------------
10348       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10349 !      implicit real*8 (a-h,o-z)
10350 !      include 'DIMENSIONS'
10351 !      include 'COMMON.IOUNITS'
10352 !      include 'COMMON.CHAIN'
10353 !      include 'COMMON.DERIV'
10354 !      include 'COMMON.INTERACT'
10355 !      include 'COMMON.CONTACTS'
10356 !      include 'COMMON.TORSION'
10357 !      include 'COMMON.VAR'
10358 !      include 'COMMON.GEO'
10359 !      include 'COMMON.FFIELD'
10360       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10361       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10362       logical :: swap
10363       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10364               iii,kkk,lll
10365       real(kind=8) :: s1,s2,s3,s4
10366 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10367 !                                                                              C
10368 !      Parallel       Antiparallel                                             C
10369 !                                                                              C
10370 !          o             o                                                     C
10371 !         /l\   /   \   /j\                                                    C
10372 !        /   \ /     \ /   \                                                   C
10373 !       /| o |o       o| o |\                                                  C
10374 !     \ j|/k\|      \  |/k\|l                                                  C
10375 !      \ /   \       \ /   \                                                   C
10376 !       o     \       o     \                                                  C
10377 !       i             i                                                        C
10378 !                                                                              C
10379 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10380 !
10381 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10382 !           energy moment and not to the cluster cumulant.
10383 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10384       iti=itortyp(itype(i,1))
10385       itj=itortyp(itype(j,1))
10386       if (j.lt.nres-1) then
10387         itj1=itortyp(itype(j+1,1))
10388       else
10389         itj1=ntortyp+1
10390       endif
10391       itk=itortyp(itype(k,1))
10392       if (k.lt.nres-1) then
10393         itk1=itortyp(itype(k+1,1))
10394       else
10395         itk1=ntortyp+1
10396       endif
10397       itl=itortyp(itype(l,1))
10398       if (l.lt.nres-1) then
10399         itl1=itortyp(itype(l+1,1))
10400       else
10401         itl1=ntortyp+1
10402       endif
10403 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10404 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10405 !d     & ' itl',itl,' itl1',itl1
10406 #ifdef MOMENT
10407       if (imat.eq.1) then
10408         s1=dip(3,jj,i)*dip(3,kk,k)
10409       else
10410         s1=dip(2,jj,j)*dip(2,kk,l)
10411       endif
10412 #endif
10413       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10414       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10415       if (j.eq.l+1) then
10416         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10417         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10418       else
10419         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10420         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10421       endif
10422       call transpose2(EUg(1,1,k),auxmat(1,1))
10423       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10424       vv(1)=pizda(1,1)-pizda(2,2)
10425       vv(2)=pizda(2,1)+pizda(1,2)
10426       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10427 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10428 #ifdef MOMENT
10429       eello6_graph4=-(s1+s2+s3+s4)
10430 #else
10431       eello6_graph4=-(s2+s3+s4)
10432 #endif
10433 ! Derivatives in gamma(i-1)
10434       if (i.gt.1) then
10435 #ifdef MOMENT
10436         if (imat.eq.1) then
10437           s1=dipderg(2,jj,i)*dip(3,kk,k)
10438         else
10439           s1=dipderg(4,jj,j)*dip(2,kk,l)
10440         endif
10441 #endif
10442         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10443         if (j.eq.l+1) then
10444           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10445           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10446         else
10447           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10448           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10449         endif
10450         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10451         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10452 !d          write (2,*) 'turn6 derivatives'
10453 #ifdef MOMENT
10454           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10455 #else
10456           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10457 #endif
10458         else
10459 #ifdef MOMENT
10460           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10461 #else
10462           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10463 #endif
10464         endif
10465       endif
10466 ! Derivatives in gamma(k-1)
10467 #ifdef MOMENT
10468       if (imat.eq.1) then
10469         s1=dip(3,jj,i)*dipderg(2,kk,k)
10470       else
10471         s1=dip(2,jj,j)*dipderg(4,kk,l)
10472       endif
10473 #endif
10474       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10475       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10476       if (j.eq.l+1) then
10477         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10478         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10479       else
10480         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10481         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10482       endif
10483       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10484       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10485       vv(1)=pizda(1,1)-pizda(2,2)
10486       vv(2)=pizda(2,1)+pizda(1,2)
10487       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10488       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10489 #ifdef MOMENT
10490         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10491 #else
10492         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10493 #endif
10494       else
10495 #ifdef MOMENT
10496         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10497 #else
10498         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10499 #endif
10500       endif
10501 ! Derivatives in gamma(j-1) or gamma(l-1)
10502       if (l.eq.j+1 .and. l.gt.1) then
10503         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10504         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10505         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10506         vv(1)=pizda(1,1)-pizda(2,2)
10507         vv(2)=pizda(2,1)+pizda(1,2)
10508         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10509         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10510       else if (j.gt.1) then
10511         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10512         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10513         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10514         vv(1)=pizda(1,1)-pizda(2,2)
10515         vv(2)=pizda(2,1)+pizda(1,2)
10516         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10517         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10518           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10519         else
10520           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10521         endif
10522       endif
10523 ! Cartesian derivatives.
10524       do iii=1,2
10525         do kkk=1,5
10526           do lll=1,3
10527 #ifdef MOMENT
10528             if (iii.eq.1) then
10529               if (imat.eq.1) then
10530                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10531               else
10532                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10533               endif
10534             else
10535               if (imat.eq.1) then
10536                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10537               else
10538                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10539               endif
10540             endif
10541 #endif
10542             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10543               auxvec(1))
10544             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10545             if (j.eq.l+1) then
10546               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10547                 b1(1,itj1),auxvec(1))
10548               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10549             else
10550               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10551                 b1(1,itl1),auxvec(1))
10552               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10553             endif
10554             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10555               pizda(1,1))
10556             vv(1)=pizda(1,1)-pizda(2,2)
10557             vv(2)=pizda(2,1)+pizda(1,2)
10558             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10559             if (swap) then
10560               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10561 #ifdef MOMENT
10562                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10563                    -(s1+s2+s4)
10564 #else
10565                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10566                    -(s2+s4)
10567 #endif
10568                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10569               else
10570 #ifdef MOMENT
10571                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10572 #else
10573                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10574 #endif
10575                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10576               endif
10577             else
10578 #ifdef MOMENT
10579               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10580 #else
10581               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10582 #endif
10583               if (l.eq.j+1) then
10584                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10585               else
10586                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10587               endif
10588             endif
10589           enddo
10590         enddo
10591       enddo
10592       return
10593       end function eello6_graph4
10594 !-----------------------------------------------------------------------------
10595       real(kind=8) function eello_turn6(i,jj,kk)
10596 !      implicit real*8 (a-h,o-z)
10597 !      include 'DIMENSIONS'
10598 !      include 'COMMON.IOUNITS'
10599 !      include 'COMMON.CHAIN'
10600 !      include 'COMMON.DERIV'
10601 !      include 'COMMON.INTERACT'
10602 !      include 'COMMON.CONTACTS'
10603 !      include 'COMMON.TORSION'
10604 !      include 'COMMON.VAR'
10605 !      include 'COMMON.GEO'
10606       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10607       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10608       real(kind=8),dimension(3) :: ggg1,ggg2
10609       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10610       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10611 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10612 !           the respective energy moment and not to the cluster cumulant.
10613 !el local variables
10614       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10615       integer :: j1,j2,l1,l2,ll
10616       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10617       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10618       s1=0.0d0
10619       s8=0.0d0
10620       s13=0.0d0
10621 !
10622       eello_turn6=0.0d0
10623       j=i+4
10624       k=i+1
10625       l=i+3
10626       iti=itortyp(itype(i,1))
10627       itk=itortyp(itype(k,1))
10628       itk1=itortyp(itype(k+1,1))
10629       itl=itortyp(itype(l,1))
10630       itj=itortyp(itype(j,1))
10631 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10632 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10633 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10634 !d        eello6=0.0d0
10635 !d        return
10636 !d      endif
10637 !d      write (iout,*)
10638 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10639 !d     &   ' and',k,l
10640 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10641       do iii=1,2
10642         do kkk=1,5
10643           do lll=1,3
10644             derx_turn(lll,kkk,iii)=0.0d0
10645           enddo
10646         enddo
10647       enddo
10648 !d      eij=1.0d0
10649 !d      ekl=1.0d0
10650 !d      ekont=1.0d0
10651       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10652 !d      eello6_5=0.0d0
10653 !d      write (2,*) 'eello6_5',eello6_5
10654 #ifdef MOMENT
10655       call transpose2(AEA(1,1,1),auxmat(1,1))
10656       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10657       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10658       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10659 #endif
10660       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10661       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10662       s2 = scalar2(b1(1,itk),vtemp1(1))
10663 #ifdef MOMENT
10664       call transpose2(AEA(1,1,2),atemp(1,1))
10665       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10666       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10667       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10668 #endif
10669       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10670       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10671       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10672 #ifdef MOMENT
10673       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10674       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10675       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10676       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10677       ss13 = scalar2(b1(1,itk),vtemp4(1))
10678       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10679 #endif
10680 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10681 !      s1=0.0d0
10682 !      s2=0.0d0
10683 !      s8=0.0d0
10684 !      s12=0.0d0
10685 !      s13=0.0d0
10686       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10687 ! Derivatives in gamma(i+2)
10688       s1d =0.0d0
10689       s8d =0.0d0
10690 #ifdef MOMENT
10691       call transpose2(AEA(1,1,1),auxmatd(1,1))
10692       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10693       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10694       call transpose2(AEAderg(1,1,2),atempd(1,1))
10695       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10696       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10697 #endif
10698       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10699       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10700       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10701 !      s1d=0.0d0
10702 !      s2d=0.0d0
10703 !      s8d=0.0d0
10704 !      s12d=0.0d0
10705 !      s13d=0.0d0
10706       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10707 ! Derivatives in gamma(i+3)
10708 #ifdef MOMENT
10709       call transpose2(AEA(1,1,1),auxmatd(1,1))
10710       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10711       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10712       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10713 #endif
10714       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10715       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10716       s2d = scalar2(b1(1,itk),vtemp1d(1))
10717 #ifdef MOMENT
10718       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10719       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10720 #endif
10721       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10722 #ifdef MOMENT
10723       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10724       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10725       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10726 #endif
10727 !      s1d=0.0d0
10728 !      s2d=0.0d0
10729 !      s8d=0.0d0
10730 !      s12d=0.0d0
10731 !      s13d=0.0d0
10732 #ifdef MOMENT
10733       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10734                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10735 #else
10736       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10737                     -0.5d0*ekont*(s2d+s12d)
10738 #endif
10739 ! Derivatives in gamma(i+4)
10740       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10741       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10742       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10743 #ifdef MOMENT
10744       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10745       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10746       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10747 #endif
10748 !      s1d=0.0d0
10749 !      s2d=0.0d0
10750 !      s8d=0.0d0
10751 !      s12d=0.0d0
10752 !      s13d=0.0d0
10753 #ifdef MOMENT
10754       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10755 #else
10756       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10757 #endif
10758 ! Derivatives in gamma(i+5)
10759 #ifdef MOMENT
10760       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10761       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10762       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10763 #endif
10764       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10765       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10766       s2d = scalar2(b1(1,itk),vtemp1d(1))
10767 #ifdef MOMENT
10768       call transpose2(AEA(1,1,2),atempd(1,1))
10769       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10770       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10771 #endif
10772       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10773       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10774 #ifdef MOMENT
10775       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10776       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10777       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10778 #endif
10779 !      s1d=0.0d0
10780 !      s2d=0.0d0
10781 !      s8d=0.0d0
10782 !      s12d=0.0d0
10783 !      s13d=0.0d0
10784 #ifdef MOMENT
10785       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10786                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10787 #else
10788       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10789                     -0.5d0*ekont*(s2d+s12d)
10790 #endif
10791 ! Cartesian derivatives
10792       do iii=1,2
10793         do kkk=1,5
10794           do lll=1,3
10795 #ifdef MOMENT
10796             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10797             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10798             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10799 #endif
10800             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10801             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10802                 vtemp1d(1))
10803             s2d = scalar2(b1(1,itk),vtemp1d(1))
10804 #ifdef MOMENT
10805             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10806             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10807             s8d = -(atempd(1,1)+atempd(2,2))* &
10808                  scalar2(cc(1,1,itl),vtemp2(1))
10809 #endif
10810             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10811                  auxmatd(1,1))
10812             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10813             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10814 !      s1d=0.0d0
10815 !      s2d=0.0d0
10816 !      s8d=0.0d0
10817 !      s12d=0.0d0
10818 !      s13d=0.0d0
10819 #ifdef MOMENT
10820             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10821               - 0.5d0*(s1d+s2d)
10822 #else
10823             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10824               - 0.5d0*s2d
10825 #endif
10826 #ifdef MOMENT
10827             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10828               - 0.5d0*(s8d+s12d)
10829 #else
10830             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10831               - 0.5d0*s12d
10832 #endif
10833           enddo
10834         enddo
10835       enddo
10836 #ifdef MOMENT
10837       do kkk=1,5
10838         do lll=1,3
10839           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10840             achuj_tempd(1,1))
10841           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10842           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10843           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10844           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10845           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10846             vtemp4d(1))
10847           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10848           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10849           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10850         enddo
10851       enddo
10852 #endif
10853 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10854 !d     &  16*eel_turn6_num
10855 !d      goto 1112
10856       if (j.lt.nres-1) then
10857         j1=j+1
10858         j2=j-1
10859       else
10860         j1=j-1
10861         j2=j-2
10862       endif
10863       if (l.lt.nres-1) then
10864         l1=l+1
10865         l2=l-1
10866       else
10867         l1=l-1
10868         l2=l-2
10869       endif
10870       do ll=1,3
10871 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10872 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10873 !grad        ghalf=0.5d0*ggg1(ll)
10874 !d        ghalf=0.0d0
10875         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10876         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10877         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10878           +ekont*derx_turn(ll,2,1)
10879         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10880         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10881           +ekont*derx_turn(ll,4,1)
10882         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10883         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10884         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10885 !grad        ghalf=0.5d0*ggg2(ll)
10886 !d        ghalf=0.0d0
10887         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10888           +ekont*derx_turn(ll,2,2)
10889         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10890         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10891           +ekont*derx_turn(ll,4,2)
10892         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10893         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10894         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10895       enddo
10896 !d      goto 1112
10897 !grad      do m=i+1,j-1
10898 !grad        do ll=1,3
10899 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10900 !grad        enddo
10901 !grad      enddo
10902 !grad      do m=k+1,l-1
10903 !grad        do ll=1,3
10904 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10905 !grad        enddo
10906 !grad      enddo
10907 !grad1112  continue
10908 !grad      do m=i+2,j2
10909 !grad        do ll=1,3
10910 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10911 !grad        enddo
10912 !grad      enddo
10913 !grad      do m=k+2,l2
10914 !grad        do ll=1,3
10915 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10916 !grad        enddo
10917 !grad      enddo
10918 !d      do iii=1,nres-3
10919 !d        write (2,*) iii,g_corr6_loc(iii)
10920 !d      enddo
10921       eello_turn6=ekont*eel_turn6
10922 !d      write (2,*) 'ekont',ekont
10923 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10924       return
10925       end function eello_turn6
10926 !-----------------------------------------------------------------------------
10927       subroutine MATVEC2(A1,V1,V2)
10928 !DIR$ INLINEALWAYS MATVEC2
10929 #ifndef OSF
10930 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10931 #endif
10932 !      implicit real*8 (a-h,o-z)
10933 !      include 'DIMENSIONS'
10934       real(kind=8),dimension(2) :: V1,V2
10935       real(kind=8),dimension(2,2) :: A1
10936       real(kind=8) :: vaux1,vaux2
10937 !      DO 1 I=1,2
10938 !        VI=0.0
10939 !        DO 3 K=1,2
10940 !    3     VI=VI+A1(I,K)*V1(K)
10941 !        Vaux(I)=VI
10942 !    1 CONTINUE
10943
10944       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10945       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10946
10947       v2(1)=vaux1
10948       v2(2)=vaux2
10949       end subroutine MATVEC2
10950 !-----------------------------------------------------------------------------
10951       subroutine MATMAT2(A1,A2,A3)
10952 #ifndef OSF
10953 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10954 #endif
10955 !      implicit real*8 (a-h,o-z)
10956 !      include 'DIMENSIONS'
10957       real(kind=8),dimension(2,2) :: A1,A2,A3
10958       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10959 !      DIMENSION AI3(2,2)
10960 !        DO  J=1,2
10961 !          A3IJ=0.0
10962 !          DO K=1,2
10963 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10964 !          enddo
10965 !          A3(I,J)=A3IJ
10966 !       enddo
10967 !      enddo
10968
10969       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10970       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10971       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10972       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10973
10974       A3(1,1)=AI3_11
10975       A3(2,1)=AI3_21
10976       A3(1,2)=AI3_12
10977       A3(2,2)=AI3_22
10978       end subroutine MATMAT2
10979 !-----------------------------------------------------------------------------
10980       real(kind=8) function scalar2(u,v)
10981 !DIR$ INLINEALWAYS scalar2
10982       implicit none
10983       real(kind=8),dimension(2) :: u,v
10984       real(kind=8) :: sc
10985       integer :: i
10986       scalar2=u(1)*v(1)+u(2)*v(2)
10987       return
10988       end function scalar2
10989 !-----------------------------------------------------------------------------
10990       subroutine transpose2(a,at)
10991 !DIR$ INLINEALWAYS transpose2
10992 #ifndef OSF
10993 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10994 #endif
10995       implicit none
10996       real(kind=8),dimension(2,2) :: a,at
10997       at(1,1)=a(1,1)
10998       at(1,2)=a(2,1)
10999       at(2,1)=a(1,2)
11000       at(2,2)=a(2,2)
11001       return
11002       end subroutine transpose2
11003 !-----------------------------------------------------------------------------
11004       subroutine transpose(n,a,at)
11005       implicit none
11006       integer :: n,i,j
11007       real(kind=8),dimension(n,n) :: a,at
11008       do i=1,n
11009         do j=1,n
11010           at(j,i)=a(i,j)
11011         enddo
11012       enddo
11013       return
11014       end subroutine transpose
11015 !-----------------------------------------------------------------------------
11016       subroutine prodmat3(a1,a2,kk,transp,prod)
11017 !DIR$ INLINEALWAYS prodmat3
11018 #ifndef OSF
11019 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11020 #endif
11021       implicit none
11022       integer :: i,j
11023       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11024       logical :: transp
11025 !rc      double precision auxmat(2,2),prod_(2,2)
11026
11027       if (transp) then
11028 !rc        call transpose2(kk(1,1),auxmat(1,1))
11029 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11030 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11031
11032            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11033        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11034            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11035        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11036            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11037        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11038            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11039        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11040
11041       else
11042 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11043 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11044
11045            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11046         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11047            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11048         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11049            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11050         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11051            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11052         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11053
11054       endif
11055 !      call transpose2(a2(1,1),a2t(1,1))
11056
11057 !rc      print *,transp
11058 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11059 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11060
11061       return
11062       end subroutine prodmat3
11063 !-----------------------------------------------------------------------------
11064 ! energy_p_new_barrier.F
11065 !-----------------------------------------------------------------------------
11066       subroutine sum_gradient
11067 !      implicit real*8 (a-h,o-z)
11068       use io_base, only: pdbout
11069 !      include 'DIMENSIONS'
11070 #ifndef ISNAN
11071       external proc_proc
11072 #ifdef WINPGI
11073 !MS$ATTRIBUTES C ::  proc_proc
11074 #endif
11075 #endif
11076 #ifdef MPI
11077       include 'mpif.h'
11078 #endif
11079       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11080                    gloc_scbuf !(3,maxres)
11081
11082       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11083 !#endif
11084 !el local variables
11085       integer :: i,j,k,ierror,ierr
11086       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11087                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11088                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11089                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11090                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11091                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11092                    gsccorr_max,gsccorrx_max,time00
11093
11094 !      include 'COMMON.SETUP'
11095 !      include 'COMMON.IOUNITS'
11096 !      include 'COMMON.FFIELD'
11097 !      include 'COMMON.DERIV'
11098 !      include 'COMMON.INTERACT'
11099 !      include 'COMMON.SBRIDGE'
11100 !      include 'COMMON.CHAIN'
11101 !      include 'COMMON.VAR'
11102 !      include 'COMMON.CONTROL'
11103 !      include 'COMMON.TIME1'
11104 !      include 'COMMON.MAXGRAD'
11105 !      include 'COMMON.SCCOR'
11106 #ifdef TIMING
11107       time01=MPI_Wtime()
11108 #endif
11109 !#define DEBUG
11110 #ifdef DEBUG
11111       write (iout,*) "sum_gradient gvdwc, gvdwx"
11112       do i=1,nres
11113         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11114          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11115       enddo
11116       call flush(iout)
11117 #endif
11118 #ifdef MPI
11119         gradbufc=0.0d0
11120         gradbufx=0.0d0
11121         gradbufc_sum=0.0d0
11122         gloc_scbuf=0.0d0
11123         glocbuf=0.0d0
11124 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11125         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11126           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11127 #endif
11128 !
11129 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11130 !            in virtual-bond-vector coordinates
11131 !
11132 #ifdef DEBUG
11133 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11134 !      do i=1,nres-1
11135 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11136 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11137 !      enddo
11138 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11139 !      do i=1,nres-1
11140 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11141 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11142 !      enddo
11143 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11144 !      do i=1,nres
11145 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11146 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11147 !         (gvdwc_scpp(j,i),j=1,3)
11148 !      enddo
11149 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11150 !      do i=1,nres
11151 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11152 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11153 !         (gelc_loc_long(j,i),j=1,3)
11154 !      enddo
11155       call flush(iout)
11156 #endif
11157 #ifdef SPLITELE
11158       do i=0,nct
11159         do j=1,3
11160           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11161                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11162                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11163                       wel_loc*gel_loc_long(j,i)+ &
11164                       wcorr*gradcorr_long(j,i)+ &
11165                       wcorr5*gradcorr5_long(j,i)+ &
11166                       wcorr6*gradcorr6_long(j,i)+ &
11167                       wturn6*gcorr6_turn_long(j,i)+ &
11168                       wstrain*ghpbc(j,i) &
11169                      +wliptran*gliptranc(j,i) &
11170                      +gradafm(j,i) &
11171                      +welec*gshieldc(j,i) &
11172                      +wcorr*gshieldc_ec(j,i) &
11173                      +wturn3*gshieldc_t3(j,i)&
11174                      +wturn4*gshieldc_t4(j,i)&
11175                      +wel_loc*gshieldc_ll(j,i)&
11176                      +wtube*gg_tube(j,i) &
11177                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11178                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11179                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11180                      wcorr_nucl*gradcorr_nucl(j,i)&
11181                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11182                      wcatprot* gradpepcat(j,i)+ &
11183                      wcatcat*gradcatcat(j,i)+   &
11184                      wscbase*gvdwc_scbase(j,i)+ &
11185                      wpepbase*gvdwc_pepbase(j,i)+&
11186                      wscpho*gvdwc_scpho(j,i)+   &
11187                      wpeppho*gvdwc_peppho(j,i)
11188
11189
11190
11191
11192
11193         enddo
11194       enddo
11195 #else
11196       do i=0,nct
11197         do j=1,3
11198           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11199                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11200                       welec*gelc_long(j,i)+ &
11201                       wbond*gradb(j,i)+ &
11202                       wel_loc*gel_loc_long(j,i)+ &
11203                       wcorr*gradcorr_long(j,i)+ &
11204                       wcorr5*gradcorr5_long(j,i)+ &
11205                       wcorr6*gradcorr6_long(j,i)+ &
11206                       wturn6*gcorr6_turn_long(j,i)+ &
11207                       wstrain*ghpbc(j,i) &
11208                      +wliptran*gliptranc(j,i) &
11209                      +gradafm(j,i) &
11210                      +welec*gshieldc(j,i)&
11211                      +wcorr*gshieldc_ec(j,i) &
11212                      +wturn4*gshieldc_t4(j,i) &
11213                      +wel_loc*gshieldc_ll(j,i)&
11214                      +wtube*gg_tube(j,i) &
11215                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11216                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11217                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11218                      wcorr_nucl*gradcorr_nucl(j,i) &
11219                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11220                      wcatprot* gradpepcat(j,i)+ &
11221                      wcatcat*gradcatcat(j,i)+   &
11222                      wscbase*gvdwc_scbase(j,i)+ &
11223                      wpepbase*gvdwc_pepbase(j,i)+&
11224                      wscpho*gvdwc_scpho(j,i)+&
11225                      wpeppho*gvdwc_peppho(j,i)
11226
11227
11228         enddo
11229       enddo
11230 #endif
11231 #ifdef MPI
11232       if (nfgtasks.gt.1) then
11233       time00=MPI_Wtime()
11234 #ifdef DEBUG
11235       write (iout,*) "gradbufc before allreduce"
11236       do i=1,nres
11237         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11238       enddo
11239       call flush(iout)
11240 #endif
11241       do i=0,nres
11242         do j=1,3
11243           gradbufc_sum(j,i)=gradbufc(j,i)
11244         enddo
11245       enddo
11246 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11247 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11248 !      time_reduce=time_reduce+MPI_Wtime()-time00
11249 #ifdef DEBUG
11250 !      write (iout,*) "gradbufc_sum after allreduce"
11251 !      do i=1,nres
11252 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11253 !      enddo
11254 !      call flush(iout)
11255 #endif
11256 #ifdef TIMING
11257 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11258 #endif
11259       do i=0,nres
11260         do k=1,3
11261           gradbufc(k,i)=0.0d0
11262         enddo
11263       enddo
11264 #ifdef DEBUG
11265       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11266       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11267                         " jgrad_end  ",jgrad_end(i),&
11268                         i=igrad_start,igrad_end)
11269 #endif
11270 !
11271 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11272 ! do not parallelize this part.
11273 !
11274 !      do i=igrad_start,igrad_end
11275 !        do j=jgrad_start(i),jgrad_end(i)
11276 !          do k=1,3
11277 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11278 !          enddo
11279 !        enddo
11280 !      enddo
11281       do j=1,3
11282         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11283       enddo
11284       do i=nres-2,-1,-1
11285         do j=1,3
11286           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11287         enddo
11288       enddo
11289 #ifdef DEBUG
11290       write (iout,*) "gradbufc after summing"
11291       do i=1,nres
11292         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11293       enddo
11294       call flush(iout)
11295 #endif
11296       else
11297 #endif
11298 !el#define DEBUG
11299 #ifdef DEBUG
11300       write (iout,*) "gradbufc"
11301       do i=1,nres
11302         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11303       enddo
11304       call flush(iout)
11305 #endif
11306 !el#undef DEBUG
11307       do i=-1,nres
11308         do j=1,3
11309           gradbufc_sum(j,i)=gradbufc(j,i)
11310           gradbufc(j,i)=0.0d0
11311         enddo
11312       enddo
11313       do j=1,3
11314         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11315       enddo
11316       do i=nres-2,-1,-1
11317         do j=1,3
11318           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11319         enddo
11320       enddo
11321 !      do i=nnt,nres-1
11322 !        do k=1,3
11323 !          gradbufc(k,i)=0.0d0
11324 !        enddo
11325 !        do j=i+1,nres
11326 !          do k=1,3
11327 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11328 !          enddo
11329 !        enddo
11330 !      enddo
11331 !el#define DEBUG
11332 #ifdef DEBUG
11333       write (iout,*) "gradbufc after summing"
11334       do i=1,nres
11335         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11336       enddo
11337       call flush(iout)
11338 #endif
11339 !el#undef DEBUG
11340 #ifdef MPI
11341       endif
11342 #endif
11343       do k=1,3
11344         gradbufc(k,nres)=0.0d0
11345       enddo
11346 !el----------------
11347 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11348 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11349 !el-----------------
11350       do i=-1,nct
11351         do j=1,3
11352 #ifdef SPLITELE
11353           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11354                       wel_loc*gel_loc(j,i)+ &
11355                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11356                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11357                       wel_loc*gel_loc_long(j,i)+ &
11358                       wcorr*gradcorr_long(j,i)+ &
11359                       wcorr5*gradcorr5_long(j,i)+ &
11360                       wcorr6*gradcorr6_long(j,i)+ &
11361                       wturn6*gcorr6_turn_long(j,i))+ &
11362                       wbond*gradb(j,i)+ &
11363                       wcorr*gradcorr(j,i)+ &
11364                       wturn3*gcorr3_turn(j,i)+ &
11365                       wturn4*gcorr4_turn(j,i)+ &
11366                       wcorr5*gradcorr5(j,i)+ &
11367                       wcorr6*gradcorr6(j,i)+ &
11368                       wturn6*gcorr6_turn(j,i)+ &
11369                       wsccor*gsccorc(j,i) &
11370                      +wscloc*gscloc(j,i)  &
11371                      +wliptran*gliptranc(j,i) &
11372                      +gradafm(j,i) &
11373                      +welec*gshieldc(j,i) &
11374                      +welec*gshieldc_loc(j,i) &
11375                      +wcorr*gshieldc_ec(j,i) &
11376                      +wcorr*gshieldc_loc_ec(j,i) &
11377                      +wturn3*gshieldc_t3(j,i) &
11378                      +wturn3*gshieldc_loc_t3(j,i) &
11379                      +wturn4*gshieldc_t4(j,i) &
11380                      +wturn4*gshieldc_loc_t4(j,i) &
11381                      +wel_loc*gshieldc_ll(j,i) &
11382                      +wel_loc*gshieldc_loc_ll(j,i) &
11383                      +wtube*gg_tube(j,i) &
11384                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11385                      +wvdwpsb*gvdwpsb1(j,i))&
11386                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11387 !                      if (i.eq.21) then
11388 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11389 !                      wturn4*gshieldc_t4(j,i), &
11390 !                     wturn4*gshieldc_loc_t4(j,i)
11391 !                       endif
11392 !                 if ((i.le.2).and.(i.ge.1))
11393 !                       print *,gradc(j,i,icg),&
11394 !                      gradbufc(j,i),welec*gelc(j,i), &
11395 !                      wel_loc*gel_loc(j,i), &
11396 !                      wscp*gvdwc_scpp(j,i), &
11397 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11398 !                      wel_loc*gel_loc_long(j,i), &
11399 !                      wcorr*gradcorr_long(j,i), &
11400 !                      wcorr5*gradcorr5_long(j,i), &
11401 !                      wcorr6*gradcorr6_long(j,i), &
11402 !                      wturn6*gcorr6_turn_long(j,i), &
11403 !                      wbond*gradb(j,i), &
11404 !                      wcorr*gradcorr(j,i), &
11405 !                      wturn3*gcorr3_turn(j,i), &
11406 !                      wturn4*gcorr4_turn(j,i), &
11407 !                      wcorr5*gradcorr5(j,i), &
11408 !                      wcorr6*gradcorr6(j,i), &
11409 !                      wturn6*gcorr6_turn(j,i), &
11410 !                      wsccor*gsccorc(j,i) &
11411 !                     ,wscloc*gscloc(j,i)  &
11412 !                     ,wliptran*gliptranc(j,i) &
11413 !                    ,gradafm(j,i) &
11414 !                     ,welec*gshieldc(j,i) &
11415 !                     ,welec*gshieldc_loc(j,i) &
11416 !                     ,wcorr*gshieldc_ec(j,i) &
11417 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11418 !                     ,wturn3*gshieldc_t3(j,i) &
11419 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11420 !                     ,wturn4*gshieldc_t4(j,i) &
11421 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11422 !                     ,wel_loc*gshieldc_ll(j,i) &
11423 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11424 !                     ,wtube*gg_tube(j,i) &
11425 !                     ,wbond_nucl*gradb_nucl(j,i) &
11426 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11427 !                     wvdwpsb*gvdwpsb1(j,i)&
11428 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11429 !
11430
11431 #else
11432           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11433                       wel_loc*gel_loc(j,i)+ &
11434                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11435                       welec*gelc_long(j,i)+ &
11436                       wel_loc*gel_loc_long(j,i)+ &
11437 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11438                       wcorr5*gradcorr5_long(j,i)+ &
11439                       wcorr6*gradcorr6_long(j,i)+ &
11440                       wturn6*gcorr6_turn_long(j,i))+ &
11441                       wbond*gradb(j,i)+ &
11442                       wcorr*gradcorr(j,i)+ &
11443                       wturn3*gcorr3_turn(j,i)+ &
11444                       wturn4*gcorr4_turn(j,i)+ &
11445                       wcorr5*gradcorr5(j,i)+ &
11446                       wcorr6*gradcorr6(j,i)+ &
11447                       wturn6*gcorr6_turn(j,i)+ &
11448                       wsccor*gsccorc(j,i) &
11449                      +wscloc*gscloc(j,i) &
11450                      +gradafm(j,i) &
11451                      +wliptran*gliptranc(j,i) &
11452                      +welec*gshieldc(j,i) &
11453                      +welec*gshieldc_loc(j,i) &
11454                      +wcorr*gshieldc_ec(j,i) &
11455                      +wcorr*gshieldc_loc_ec(j,i) &
11456                      +wturn3*gshieldc_t3(j,i) &
11457                      +wturn3*gshieldc_loc_t3(j,i) &
11458                      +wturn4*gshieldc_t4(j,i) &
11459                      +wturn4*gshieldc_loc_t4(j,i) &
11460                      +wel_loc*gshieldc_ll(j,i) &
11461                      +wel_loc*gshieldc_loc_ll(j,i) &
11462                      +wtube*gg_tube(j,i) &
11463                      +wbond_nucl*gradb_nucl(j,i) &
11464                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11465                      +wvdwpsb*gvdwpsb1(j,i))&
11466                      +wsbloc*gsbloc(j,i)
11467
11468
11469
11470
11471 #endif
11472           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11473                         wbond*gradbx(j,i)+ &
11474                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11475                         wsccor*gsccorx(j,i) &
11476                        +wscloc*gsclocx(j,i) &
11477                        +wliptran*gliptranx(j,i) &
11478                        +welec*gshieldx(j,i)     &
11479                        +wcorr*gshieldx_ec(j,i)  &
11480                        +wturn3*gshieldx_t3(j,i) &
11481                        +wturn4*gshieldx_t4(j,i) &
11482                        +wel_loc*gshieldx_ll(j,i)&
11483                        +wtube*gg_tube_sc(j,i)   &
11484                        +wbond_nucl*gradbx_nucl(j,i) &
11485                        +wvdwsb*gvdwsbx(j,i) &
11486                        +welsb*gelsbx(j,i) &
11487                        +wcorr_nucl*gradxorr_nucl(j,i)&
11488                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11489                        +wsbloc*gsblocx(j,i) &
11490                        +wcatprot* gradpepcatx(j,i)&
11491                        +wscbase*gvdwx_scbase(j,i) &
11492                        +wpepbase*gvdwx_pepbase(j,i)&
11493                        +wscpho*gvdwx_scpho(j,i)
11494 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11495
11496         enddo
11497       enddo
11498 !#define DEBUG
11499 #ifdef DEBUG
11500       write (iout,*) "gloc before adding corr"
11501       do i=1,4*nres
11502         write (iout,*) i,gloc(i,icg)
11503       enddo
11504 #endif
11505       do i=1,nres-3
11506         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11507          +wcorr5*g_corr5_loc(i) &
11508          +wcorr6*g_corr6_loc(i) &
11509          +wturn4*gel_loc_turn4(i) &
11510          +wturn3*gel_loc_turn3(i) &
11511          +wturn6*gel_loc_turn6(i) &
11512          +wel_loc*gel_loc_loc(i)
11513       enddo
11514 #ifdef DEBUG
11515       write (iout,*) "gloc after adding corr"
11516       do i=1,4*nres
11517         write (iout,*) i,gloc(i,icg)
11518       enddo
11519 #endif
11520 !#undef DEBUG
11521 #ifdef MPI
11522       if (nfgtasks.gt.1) then
11523         do j=1,3
11524           do i=0,nres
11525             gradbufc(j,i)=gradc(j,i,icg)
11526             gradbufx(j,i)=gradx(j,i,icg)
11527           enddo
11528         enddo
11529         do i=1,4*nres
11530           glocbuf(i)=gloc(i,icg)
11531         enddo
11532 !#define DEBUG
11533 #ifdef DEBUG
11534       write (iout,*) "gloc_sc before reduce"
11535       do i=1,nres
11536        do j=1,1
11537         write (iout,*) i,j,gloc_sc(j,i,icg)
11538        enddo
11539       enddo
11540 #endif
11541 !#undef DEBUG
11542         do i=0,nres
11543          do j=1,3
11544           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11545          enddo
11546         enddo
11547         time00=MPI_Wtime()
11548         call MPI_Barrier(FG_COMM,IERR)
11549         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11550         time00=MPI_Wtime()
11551         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11552           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11553         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11554           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11555         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11556           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11557         time_reduce=time_reduce+MPI_Wtime()-time00
11558         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
11559           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11560         time_reduce=time_reduce+MPI_Wtime()-time00
11561 !#define DEBUG
11562 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11563 #ifdef DEBUG
11564       write (iout,*) "gloc_sc after reduce"
11565       do i=0,nres
11566        do j=1,1
11567         write (iout,*) i,j,gloc_sc(j,i,icg)
11568        enddo
11569       enddo
11570 #endif
11571 !#undef DEBUG
11572 #ifdef DEBUG
11573       write (iout,*) "gloc after reduce"
11574       do i=1,4*nres
11575         write (iout,*) i,gloc(i,icg)
11576       enddo
11577 #endif
11578       endif
11579 #endif
11580       if (gnorm_check) then
11581 !
11582 ! Compute the maximum elements of the gradient
11583 !
11584       gvdwc_max=0.0d0
11585       gvdwc_scp_max=0.0d0
11586       gelc_max=0.0d0
11587       gvdwpp_max=0.0d0
11588       gradb_max=0.0d0
11589       ghpbc_max=0.0d0
11590       gradcorr_max=0.0d0
11591       gel_loc_max=0.0d0
11592       gcorr3_turn_max=0.0d0
11593       gcorr4_turn_max=0.0d0
11594       gradcorr5_max=0.0d0
11595       gradcorr6_max=0.0d0
11596       gcorr6_turn_max=0.0d0
11597       gsccorc_max=0.0d0
11598       gscloc_max=0.0d0
11599       gvdwx_max=0.0d0
11600       gradx_scp_max=0.0d0
11601       ghpbx_max=0.0d0
11602       gradxorr_max=0.0d0
11603       gsccorx_max=0.0d0
11604       gsclocx_max=0.0d0
11605       do i=1,nct
11606         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11607         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11608         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11609         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11610          gvdwc_scp_max=gvdwc_scp_norm
11611         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11612         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11613         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11614         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11615         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11616         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11617         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11618         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11619         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11620         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11621         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11622         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11623         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11624           gcorr3_turn(1,i)))
11625         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11626           gcorr3_turn_max=gcorr3_turn_norm
11627         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11628           gcorr4_turn(1,i)))
11629         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11630           gcorr4_turn_max=gcorr4_turn_norm
11631         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11632         if (gradcorr5_norm.gt.gradcorr5_max) &
11633           gradcorr5_max=gradcorr5_norm
11634         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11635         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11636         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11637           gcorr6_turn(1,i)))
11638         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11639           gcorr6_turn_max=gcorr6_turn_norm
11640         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11641         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11642         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11643         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11644         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11645         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11646         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11647         if (gradx_scp_norm.gt.gradx_scp_max) &
11648           gradx_scp_max=gradx_scp_norm
11649         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11650         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11651         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11652         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11653         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11654         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11655         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11656         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11657       enddo
11658       if (gradout) then
11659 #ifdef AIX
11660         open(istat,file=statname,position="append")
11661 #else
11662         open(istat,file=statname,access="append")
11663 #endif
11664         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11665            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11666            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11667            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11668            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11669            gsccorx_max,gsclocx_max
11670         close(istat)
11671         if (gvdwc_max.gt.1.0d4) then
11672           write (iout,*) "gvdwc gvdwx gradb gradbx"
11673           do i=nnt,nct
11674             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11675               gradb(j,i),gradbx(j,i),j=1,3)
11676           enddo
11677           call pdbout(0.0d0,'cipiszcze',iout)
11678           call flush(iout)
11679         endif
11680       endif
11681       endif
11682 !#define DEBUG
11683 #ifdef DEBUG
11684       write (iout,*) "gradc gradx gloc"
11685       do i=1,nres
11686         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11687          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11688       enddo
11689 #endif
11690 !#undef DEBUG
11691 #ifdef TIMING
11692       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11693 #endif
11694       return
11695       end subroutine sum_gradient
11696 !-----------------------------------------------------------------------------
11697       subroutine sc_grad
11698 !      implicit real*8 (a-h,o-z)
11699       use calc_data
11700 !      include 'DIMENSIONS'
11701 !      include 'COMMON.CHAIN'
11702 !      include 'COMMON.DERIV'
11703 !      include 'COMMON.CALC'
11704 !      include 'COMMON.IOUNITS'
11705       real(kind=8), dimension(3) :: dcosom1,dcosom2
11706 !      print *,"wchodze"
11707       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11708           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11709       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11710           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11711
11712       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11713            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11714            +dCAVdOM12+ dGCLdOM12
11715 ! diagnostics only
11716 !      eom1=0.0d0
11717 !      eom2=0.0d0
11718 !      eom12=evdwij*eps1_om12
11719 ! end diagnostics
11720 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11721 !       " sigder",sigder
11722 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11723 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11724 !C      print *,sss_ele_cut,'in sc_grad'
11725       do k=1,3
11726         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11727         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11728       enddo
11729       do k=1,3
11730         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11731 !C      print *,'gg',k,gg(k)
11732        enddo
11733 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11734 !      write (iout,*) "gg",(gg(k),k=1,3)
11735       do k=1,3
11736         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11737                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11738                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11739                   *sss_ele_cut
11740
11741         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11742                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11743                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11744                   *sss_ele_cut
11745
11746 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11747 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11748 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11749 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11750       enddo
11751 !
11752 ! Calculate the components of the gradient in DC and X
11753 !
11754 !grad      do k=i,j-1
11755 !grad        do l=1,3
11756 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11757 !grad        enddo
11758 !grad      enddo
11759       do l=1,3
11760         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11761         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11762       enddo
11763       return
11764       end subroutine sc_grad
11765
11766       subroutine sc_grad_cat
11767       use calc_data
11768       real(kind=8), dimension(3) :: dcosom1,dcosom2
11769       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11770           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11771       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11772           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11773
11774       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11775            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11776            +dCAVdOM12+ dGCLdOM12
11777 ! diagnostics only
11778 !      eom1=0.0d0
11779 !      eom2=0.0d0
11780 !      eom12=evdwij*eps1_om12
11781 ! end diagnostics
11782
11783       do k=1,3
11784         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11785         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11786       enddo
11787       do k=1,3
11788         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11789 !C      print *,'gg',k,gg(k)
11790        enddo
11791 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11792 !      write (iout,*) "gg",(gg(k),k=1,3)
11793       do k=1,3
11794         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11795                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11796                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11797
11798 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11799 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11800 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11801
11802 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11803 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11804 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11805 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11806       enddo
11807 !
11808 ! Calculate the components of the gradient in DC and X
11809 !
11810       do l=1,3
11811         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11812         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11813       enddo
11814       end subroutine sc_grad_cat
11815
11816       subroutine sc_grad_cat_pep
11817       use calc_data
11818       real(kind=8), dimension(3) :: dcosom1,dcosom2
11819       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11820           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11821       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11822           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11823
11824       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11825            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11826            +dCAVdOM12+ dGCLdOM12
11827 ! diagnostics only
11828 !      eom1=0.0d0
11829 !      eom2=0.0d0
11830 !      eom12=evdwij*eps1_om12
11831 ! end diagnostics
11832
11833       do k=1,3
11834         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
11835         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
11836         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
11837         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
11838                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
11839                  *dsci_inv*2.0 &
11840                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11841         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
11842                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
11843                  *dsci_inv*2.0 &
11844                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11845         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
11846       enddo
11847       end subroutine sc_grad_cat_pep
11848
11849 #ifdef CRYST_THETA
11850 !-----------------------------------------------------------------------------
11851       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11852
11853       use comm_calcthet
11854 !      implicit real*8 (a-h,o-z)
11855 !      include 'DIMENSIONS'
11856 !      include 'COMMON.LOCAL'
11857 !      include 'COMMON.IOUNITS'
11858 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11859 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11860 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11861       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11862       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11863 !el      integer :: it
11864 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11865 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11866 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11867 !el local variables
11868
11869       delthec=thetai-thet_pred_mean
11870       delthe0=thetai-theta0i
11871 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11872       t3 = thetai-thet_pred_mean
11873       t6 = t3**2
11874       t9 = term1
11875       t12 = t3*sigcsq
11876       t14 = t12+t6*sigsqtc
11877       t16 = 1.0d0
11878       t21 = thetai-theta0i
11879       t23 = t21**2
11880       t26 = term2
11881       t27 = t21*t26
11882       t32 = termexp
11883       t40 = t32**2
11884       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11885        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11886        *(-t12*t9-ak*sig0inv*t27)
11887       return
11888       end subroutine mixder
11889 #endif
11890 !-----------------------------------------------------------------------------
11891 ! cartder.F
11892 !-----------------------------------------------------------------------------
11893       subroutine cartder
11894 !-----------------------------------------------------------------------------
11895 ! This subroutine calculates the derivatives of the consecutive virtual
11896 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11897 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11898 ! in the angles alpha and omega, describing the location of a side chain
11899 ! in its local coordinate system.
11900 !
11901 ! The derivatives are stored in the following arrays:
11902 !
11903 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11904 ! The structure is as follows:
11905 !
11906 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11907 ! 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)
11908 !         . . . . . . . . . . . .  . . . . . .
11909 ! 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)
11910 !                          .
11911 !                          .
11912 !                          .
11913 ! 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)
11914 !
11915 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11916 ! The structure is same as above.
11917 !
11918 ! DCDS - the derivatives of the side chain vectors in the local spherical
11919 ! andgles alph and omega:
11920 !
11921 ! 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)
11922 ! 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)
11923 !                          .
11924 !                          .
11925 !                          .
11926 ! 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)
11927 !
11928 ! Version of March '95, based on an early version of November '91.
11929 !
11930 !**********************************************************************
11931 !      implicit real*8 (a-h,o-z)
11932 !      include 'DIMENSIONS'
11933 !      include 'COMMON.VAR'
11934 !      include 'COMMON.CHAIN'
11935 !      include 'COMMON.DERIV'
11936 !      include 'COMMON.GEO'
11937 !      include 'COMMON.LOCAL'
11938 !      include 'COMMON.INTERACT'
11939       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11940       real(kind=8),dimension(3,3) :: dp,temp
11941 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11942       real(kind=8),dimension(3) :: xx,xx1
11943 !el local variables
11944       integer :: i,k,l,j,m,ind,ind1,jjj
11945       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11946                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11947                  sint2,xp,yp,xxp,yyp,zzp,dj
11948
11949 !      common /przechowalnia/ fromto
11950       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11951 ! get the position of the jth ijth fragment of the chain coordinate system
11952 ! in the fromto array.
11953 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11954 !
11955 !      maxdim=(nres-1)*(nres-2)/2
11956 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11957 ! calculate the derivatives of transformation matrix elements in theta
11958 !
11959
11960 !el      call flush(iout) !el
11961       do i=1,nres-2
11962         rdt(1,1,i)=-rt(1,2,i)
11963         rdt(1,2,i)= rt(1,1,i)
11964         rdt(1,3,i)= 0.0d0
11965         rdt(2,1,i)=-rt(2,2,i)
11966         rdt(2,2,i)= rt(2,1,i)
11967         rdt(2,3,i)= 0.0d0
11968         rdt(3,1,i)=-rt(3,2,i)
11969         rdt(3,2,i)= rt(3,1,i)
11970         rdt(3,3,i)= 0.0d0
11971       enddo
11972 !
11973 ! derivatives in phi
11974 !
11975       do i=2,nres-2
11976         drt(1,1,i)= 0.0d0
11977         drt(1,2,i)= 0.0d0
11978         drt(1,3,i)= 0.0d0
11979         drt(2,1,i)= rt(3,1,i)
11980         drt(2,2,i)= rt(3,2,i)
11981         drt(2,3,i)= rt(3,3,i)
11982         drt(3,1,i)=-rt(2,1,i)
11983         drt(3,2,i)=-rt(2,2,i)
11984         drt(3,3,i)=-rt(2,3,i)
11985       enddo
11986 !
11987 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11988 !
11989       do i=2,nres-2
11990         ind=indmat(i,i+1)
11991         do k=1,3
11992           do l=1,3
11993             temp(k,l)=rt(k,l,i)
11994           enddo
11995         enddo
11996         do k=1,3
11997           do l=1,3
11998             fromto(k,l,ind)=temp(k,l)
11999           enddo
12000         enddo
12001         do j=i+1,nres-2
12002           ind=indmat(i,j+1)
12003           do k=1,3
12004             do l=1,3
12005               dpkl=0.0d0
12006               do m=1,3
12007                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12008               enddo
12009               dp(k,l)=dpkl
12010               fromto(k,l,ind)=dpkl
12011             enddo
12012           enddo
12013           do k=1,3
12014             do l=1,3
12015               temp(k,l)=dp(k,l)
12016             enddo
12017           enddo
12018         enddo
12019       enddo
12020 !
12021 ! Calculate derivatives.
12022 !
12023       ind1=0
12024       do i=1,nres-2
12025       ind1=ind1+1
12026 !
12027 ! Derivatives of DC(i+1) in theta(i+2)
12028 !
12029         do j=1,3
12030           do k=1,2
12031             dpjk=0.0D0
12032             do l=1,3
12033               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12034             enddo
12035             dp(j,k)=dpjk
12036             prordt(j,k,i)=dp(j,k)
12037           enddo
12038           dp(j,3)=0.0D0
12039           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12040         enddo
12041 !
12042 ! Derivatives of SC(i+1) in theta(i+2)
12043 !
12044         xx1(1)=-0.5D0*xloc(2,i+1)
12045         xx1(2)= 0.5D0*xloc(1,i+1)
12046         do j=1,3
12047           xj=0.0D0
12048           do k=1,2
12049             xj=xj+r(j,k,i)*xx1(k)
12050           enddo
12051           xx(j)=xj
12052         enddo
12053         do j=1,3
12054           rj=0.0D0
12055           do k=1,3
12056             rj=rj+prod(j,k,i)*xx(k)
12057           enddo
12058           dxdv(j,ind1)=rj
12059         enddo
12060 !
12061 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12062 ! than the other off-diagonal derivatives.
12063 !
12064         do j=1,3
12065           dxoiij=0.0D0
12066           do k=1,3
12067             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12068           enddo
12069           dxdv(j,ind1+1)=dxoiij
12070         enddo
12071 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12072 !
12073 ! Derivatives of DC(i+1) in phi(i+2)
12074 !
12075         do j=1,3
12076           do k=1,3
12077             dpjk=0.0
12078             do l=2,3
12079               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12080             enddo
12081             dp(j,k)=dpjk
12082             prodrt(j,k,i)=dp(j,k)
12083           enddo
12084           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12085         enddo
12086 !
12087 ! Derivatives of SC(i+1) in phi(i+2)
12088 !
12089         xx(1)= 0.0D0
12090         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12091         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12092         do j=1,3
12093           rj=0.0D0
12094           do k=2,3
12095             rj=rj+prod(j,k,i)*xx(k)
12096           enddo
12097           dxdv(j+3,ind1)=-rj
12098         enddo
12099 !
12100 ! Derivatives of SC(i+1) in phi(i+3).
12101 !
12102         do j=1,3
12103           dxoiij=0.0D0
12104           do k=1,3
12105             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12106           enddo
12107           dxdv(j+3,ind1+1)=dxoiij
12108         enddo
12109 !
12110 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12111 ! theta(nres) and phi(i+3) thru phi(nres).
12112 !
12113         do j=i+1,nres-2
12114         ind1=ind1+1
12115         ind=indmat(i+1,j+1)
12116 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12117           do k=1,3
12118             do l=1,3
12119               tempkl=0.0D0
12120               do m=1,2
12121                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12122               enddo
12123               temp(k,l)=tempkl
12124             enddo
12125           enddo
12126 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12127 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12128 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12129 ! Derivatives of virtual-bond vectors in theta
12130           do k=1,3
12131             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12132           enddo
12133 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12134 ! Derivatives of SC vectors in theta
12135           do k=1,3
12136             dxoijk=0.0D0
12137             do l=1,3
12138               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12139             enddo
12140             dxdv(k,ind1+1)=dxoijk
12141           enddo
12142 !
12143 !--- Calculate the derivatives in phi
12144 !
12145           do k=1,3
12146             do l=1,3
12147               tempkl=0.0D0
12148               do m=1,3
12149                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12150               enddo
12151               temp(k,l)=tempkl
12152             enddo
12153           enddo
12154           do k=1,3
12155             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12156         enddo
12157           do k=1,3
12158             dxoijk=0.0D0
12159             do l=1,3
12160               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12161             enddo
12162             dxdv(k+3,ind1+1)=dxoijk
12163           enddo
12164         enddo
12165       enddo
12166 !
12167 ! Derivatives in alpha and omega:
12168 !
12169       do i=2,nres-1
12170 !       dsci=dsc(itype(i,1))
12171         dsci=vbld(i+nres)
12172 #ifdef OSF
12173         alphi=alph(i)
12174         omegi=omeg(i)
12175         if(alphi.ne.alphi) alphi=100.0
12176         if(omegi.ne.omegi) omegi=-100.0
12177 #else
12178       alphi=alph(i)
12179       omegi=omeg(i)
12180 #endif
12181 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12182       cosalphi=dcos(alphi)
12183       sinalphi=dsin(alphi)
12184       cosomegi=dcos(omegi)
12185       sinomegi=dsin(omegi)
12186       temp(1,1)=-dsci*sinalphi
12187       temp(2,1)= dsci*cosalphi*cosomegi
12188       temp(3,1)=-dsci*cosalphi*sinomegi
12189       temp(1,2)=0.0D0
12190       temp(2,2)=-dsci*sinalphi*sinomegi
12191       temp(3,2)=-dsci*sinalphi*cosomegi
12192       theta2=pi-0.5D0*theta(i+1)
12193       cost2=dcos(theta2)
12194       sint2=dsin(theta2)
12195       jjj=0
12196 !d      print *,((temp(l,k),l=1,3),k=1,2)
12197         do j=1,2
12198         xp=temp(1,j)
12199         yp=temp(2,j)
12200         xxp= xp*cost2+yp*sint2
12201         yyp=-xp*sint2+yp*cost2
12202         zzp=temp(3,j)
12203         xx(1)=xxp
12204         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12205         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12206         do k=1,3
12207           dj=0.0D0
12208           do l=1,3
12209             dj=dj+prod(k,l,i-1)*xx(l)
12210             enddo
12211           dxds(jjj+k,i)=dj
12212           enddo
12213         jjj=jjj+3
12214       enddo
12215       enddo
12216       return
12217       end subroutine cartder
12218 !-----------------------------------------------------------------------------
12219 ! checkder_p.F
12220 !-----------------------------------------------------------------------------
12221       subroutine check_cartgrad
12222 ! Check the gradient of Cartesian coordinates in internal coordinates.
12223 !      implicit real*8 (a-h,o-z)
12224 !      include 'DIMENSIONS'
12225 !      include 'COMMON.IOUNITS'
12226 !      include 'COMMON.VAR'
12227 !      include 'COMMON.CHAIN'
12228 !      include 'COMMON.GEO'
12229 !      include 'COMMON.LOCAL'
12230 !      include 'COMMON.DERIV'
12231       real(kind=8),dimension(6,nres) :: temp
12232       real(kind=8),dimension(3) :: xx,gg
12233       integer :: i,k,j,ii
12234       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12235 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12236 !
12237 ! Check the gradient of the virtual-bond and SC vectors in the internal
12238 ! coordinates.
12239 !
12240       aincr=1.0d-6
12241       aincr2=5.0d-7
12242       call cartder
12243       write (iout,'(a)') '**************** dx/dalpha'
12244       write (iout,'(a)')
12245       do i=2,nres-1
12246       alphi=alph(i)
12247       alph(i)=alph(i)+aincr
12248       do k=1,3
12249         temp(k,i)=dc(k,nres+i)
12250         enddo
12251       call chainbuild
12252       do k=1,3
12253         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12254         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12255         enddo
12256         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12257         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12258         write (iout,'(a)')
12259       alph(i)=alphi
12260       call chainbuild
12261       enddo
12262       write (iout,'(a)')
12263       write (iout,'(a)') '**************** dx/domega'
12264       write (iout,'(a)')
12265       do i=2,nres-1
12266       omegi=omeg(i)
12267       omeg(i)=omeg(i)+aincr
12268       do k=1,3
12269         temp(k,i)=dc(k,nres+i)
12270         enddo
12271       call chainbuild
12272       do k=1,3
12273           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12274           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12275                 (aincr*dabs(dxds(k+3,i))+aincr))
12276         enddo
12277         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12278             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12279         write (iout,'(a)')
12280       omeg(i)=omegi
12281       call chainbuild
12282       enddo
12283       write (iout,'(a)')
12284       write (iout,'(a)') '**************** dx/dtheta'
12285       write (iout,'(a)')
12286       do i=3,nres
12287       theti=theta(i)
12288         theta(i)=theta(i)+aincr
12289         do j=i-1,nres-1
12290           do k=1,3
12291             temp(k,j)=dc(k,nres+j)
12292           enddo
12293         enddo
12294         call chainbuild
12295         do j=i-1,nres-1
12296         ii = indmat(i-2,j)
12297 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12298         do k=1,3
12299           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12300           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12301                   (aincr*dabs(dxdv(k,ii))+aincr))
12302           enddo
12303           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12304               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12305           write(iout,'(a)')
12306         enddo
12307         write (iout,'(a)')
12308         theta(i)=theti
12309         call chainbuild
12310       enddo
12311       write (iout,'(a)') '***************** dx/dphi'
12312       write (iout,'(a)')
12313       do i=4,nres
12314         phi(i)=phi(i)+aincr
12315         do j=i-1,nres-1
12316           do k=1,3
12317             temp(k,j)=dc(k,nres+j)
12318           enddo
12319         enddo
12320         call chainbuild
12321         do j=i-1,nres-1
12322         ii = indmat(i-2,j)
12323 !         print *,'ii=',ii
12324         do k=1,3
12325           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12326             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12327                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12328           enddo
12329           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12330               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12331           write(iout,'(a)')
12332         enddo
12333         phi(i)=phi(i)-aincr
12334         call chainbuild
12335       enddo
12336       write (iout,'(a)') '****************** ddc/dtheta'
12337       do i=1,nres-2
12338         thet=theta(i+2)
12339         theta(i+2)=thet+aincr
12340         do j=i,nres
12341           do k=1,3
12342             temp(k,j)=dc(k,j)
12343           enddo
12344         enddo
12345         call chainbuild
12346         do j=i+1,nres-1
12347         ii = indmat(i,j)
12348 !         print *,'ii=',ii
12349         do k=1,3
12350           gg(k)=(dc(k,j)-temp(k,j))/aincr
12351           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12352                  (aincr*dabs(dcdv(k,ii))+aincr))
12353           enddo
12354           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12355                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12356         write (iout,'(a)')
12357         enddo
12358         do j=1,nres
12359           do k=1,3
12360             dc(k,j)=temp(k,j)
12361           enddo
12362         enddo
12363         theta(i+2)=thet
12364       enddo
12365       write (iout,'(a)') '******************* ddc/dphi'
12366       do i=1,nres-3
12367         phii=phi(i+3)
12368         phi(i+3)=phii+aincr
12369         do j=1,nres
12370           do k=1,3
12371             temp(k,j)=dc(k,j)
12372           enddo
12373         enddo
12374         call chainbuild
12375         do j=i+2,nres-1
12376         ii = indmat(i+1,j)
12377 !         print *,'ii=',ii
12378         do k=1,3
12379           gg(k)=(dc(k,j)-temp(k,j))/aincr
12380             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12381                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12382           enddo
12383           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12384                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12385         write (iout,'(a)')
12386         enddo
12387         do j=1,nres
12388           do k=1,3
12389             dc(k,j)=temp(k,j)
12390           enddo
12391         enddo
12392         phi(i+3)=phii
12393       enddo
12394       return
12395       end subroutine check_cartgrad
12396 !-----------------------------------------------------------------------------
12397       subroutine check_ecart
12398 ! Check the gradient of the energy in Cartesian coordinates.
12399 !     implicit real*8 (a-h,o-z)
12400 !     include 'DIMENSIONS'
12401 !     include 'COMMON.CHAIN'
12402 !     include 'COMMON.DERIV'
12403 !     include 'COMMON.IOUNITS'
12404 !     include 'COMMON.VAR'
12405 !     include 'COMMON.CONTACTS'
12406       use comm_srutu
12407 !el      integer :: icall
12408 !el      common /srutu/ icall
12409       real(kind=8),dimension(6) :: ggg
12410       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12411       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12412       real(kind=8),dimension(6,nres) :: grad_s
12413       real(kind=8),dimension(0:n_ene) :: energia,energia1
12414       integer :: uiparm(1)
12415       real(kind=8) :: urparm(1)
12416 !EL      external fdum
12417       integer :: nf,i,j,k
12418       real(kind=8) :: aincr,etot,etot1
12419       icg=1
12420       nf=0
12421       nfl=0
12422       call zerograd
12423       aincr=1.0D-5
12424       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12425       nf=0
12426       icall=0
12427       call geom_to_var(nvar,x)
12428       call etotal(energia)
12429       etot=energia(0)
12430 !el      call enerprint(energia)
12431       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12432       icall =1
12433       do i=1,nres
12434         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12435       enddo
12436       do i=1,nres
12437       do j=1,3
12438         grad_s(j,i)=gradc(j,i,icg)
12439         grad_s(j+3,i)=gradx(j,i,icg)
12440         enddo
12441       enddo
12442       call flush(iout)
12443       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12444       do i=1,nres
12445         do j=1,3
12446         xx(j)=c(j,i+nres)
12447         ddc(j)=dc(j,i)
12448         ddx(j)=dc(j,i+nres)
12449         enddo
12450       do j=1,3
12451         dc(j,i)=dc(j,i)+aincr
12452         do k=i+1,nres
12453           c(j,k)=c(j,k)+aincr
12454           c(j,k+nres)=c(j,k+nres)+aincr
12455           enddo
12456           call zerograd
12457           call etotal(energia1)
12458           etot1=energia1(0)
12459         ggg(j)=(etot1-etot)/aincr
12460         dc(j,i)=ddc(j)
12461         do k=i+1,nres
12462           c(j,k)=c(j,k)-aincr
12463           c(j,k+nres)=c(j,k+nres)-aincr
12464           enddo
12465         enddo
12466       do j=1,3
12467         c(j,i+nres)=c(j,i+nres)+aincr
12468         dc(j,i+nres)=dc(j,i+nres)+aincr
12469           call zerograd
12470           call etotal(energia1)
12471           etot1=energia1(0)
12472         ggg(j+3)=(etot1-etot)/aincr
12473         c(j,i+nres)=xx(j)
12474         dc(j,i+nres)=ddx(j)
12475         enddo
12476       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12477          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12478       enddo
12479       return
12480       end subroutine check_ecart
12481 #ifdef CARGRAD
12482 !-----------------------------------------------------------------------------
12483       subroutine check_ecartint
12484 ! Check the gradient of the energy in Cartesian coordinates.
12485       use io_base, only: intout
12486 !      implicit real*8 (a-h,o-z)
12487 !      include 'DIMENSIONS'
12488 !      include 'COMMON.CONTROL'
12489 !      include 'COMMON.CHAIN'
12490 !      include 'COMMON.DERIV'
12491 !      include 'COMMON.IOUNITS'
12492 !      include 'COMMON.VAR'
12493 !      include 'COMMON.CONTACTS'
12494 !      include 'COMMON.MD'
12495 !      include 'COMMON.LOCAL'
12496 !      include 'COMMON.SPLITELE'
12497       use comm_srutu
12498 !el      integer :: icall
12499 !el      common /srutu/ icall
12500       real(kind=8),dimension(6) :: ggg,ggg1
12501       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12502       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12503       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12504       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12505       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12506       real(kind=8),dimension(0:n_ene) :: energia,energia1
12507       integer :: uiparm(1)
12508       real(kind=8) :: urparm(1)
12509 !EL      external fdum
12510       integer :: i,j,k,nf
12511       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12512                    etot21,etot22
12513       r_cut=2.0d0
12514       rlambd=0.3d0
12515       icg=1
12516       nf=0
12517       nfl=0
12518       call intout
12519 !      call intcartderiv
12520 !      call checkintcartgrad
12521       call zerograd
12522       aincr=1.0D-5
12523       write(iout,*) 'Calling CHECK_ECARTINT.'
12524       nf=0
12525       icall=0
12526       call geom_to_var(nvar,x)
12527       write (iout,*) "split_ene ",split_ene
12528       call flush(iout)
12529       if (.not.split_ene) then
12530         call zerograd
12531         call etotal(energia)
12532         etot=energia(0)
12533         call cartgrad
12534         icall =1
12535         do i=1,nres
12536           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12537         enddo
12538         do j=1,3
12539           grad_s(j,0)=gcart(j,0)
12540         enddo
12541         do i=1,nres
12542           do j=1,3
12543             grad_s(j,i)=gcart(j,i)
12544             grad_s(j+3,i)=gxcart(j,i)
12545           enddo
12546         enddo
12547       else
12548 !- split gradient check
12549         call zerograd
12550         call etotal_long(energia)
12551 !el        call enerprint(energia)
12552         call cartgrad
12553         icall =1
12554         do i=1,nres
12555           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12556           (gxcart(j,i),j=1,3)
12557         enddo
12558         do j=1,3
12559           grad_s(j,0)=gcart(j,0)
12560         enddo
12561         do i=1,nres
12562           do j=1,3
12563             grad_s(j,i)=gcart(j,i)
12564             grad_s(j+3,i)=gxcart(j,i)
12565           enddo
12566         enddo
12567         call zerograd
12568         call etotal_short(energia)
12569         call enerprint(energia)
12570         call cartgrad
12571         icall =1
12572         do i=1,nres
12573           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12574           (gxcart(j,i),j=1,3)
12575         enddo
12576         do j=1,3
12577           grad_s1(j,0)=gcart(j,0)
12578         enddo
12579         do i=1,nres
12580           do j=1,3
12581             grad_s1(j,i)=gcart(j,i)
12582             grad_s1(j+3,i)=gxcart(j,i)
12583           enddo
12584         enddo
12585       endif
12586       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12587 !      do i=1,nres
12588       do i=nnt,nct
12589         do j=1,3
12590           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12591           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12592         ddc(j)=c(j,i)
12593         ddx(j)=c(j,i+nres)
12594           dcnorm_safe1(j)=dc_norm(j,i-1)
12595           dcnorm_safe2(j)=dc_norm(j,i)
12596           dxnorm_safe(j)=dc_norm(j,i+nres)
12597         enddo
12598       do j=1,3
12599         c(j,i)=ddc(j)+aincr
12600           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12601           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12602           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12603           dc(j,i)=c(j,i+1)-c(j,i)
12604           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12605           call int_from_cart1(.false.)
12606           if (.not.split_ene) then
12607            call zerograd
12608             call etotal(energia1)
12609             etot1=energia1(0)
12610             write (iout,*) "ij",i,j," etot1",etot1
12611           else
12612 !- split gradient
12613             call etotal_long(energia1)
12614             etot11=energia1(0)
12615             call etotal_short(energia1)
12616             etot12=energia1(0)
12617           endif
12618 !- end split gradient
12619 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12620         c(j,i)=ddc(j)-aincr
12621           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12622           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12623           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12624           dc(j,i)=c(j,i+1)-c(j,i)
12625           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12626           call int_from_cart1(.false.)
12627           if (.not.split_ene) then
12628             call zerograd
12629             call etotal(energia1)
12630             etot2=energia1(0)
12631             write (iout,*) "ij",i,j," etot2",etot2
12632           ggg(j)=(etot1-etot2)/(2*aincr)
12633           else
12634 !- split gradient
12635             call etotal_long(energia1)
12636             etot21=energia1(0)
12637           ggg(j)=(etot11-etot21)/(2*aincr)
12638             call etotal_short(energia1)
12639             etot22=energia1(0)
12640           ggg1(j)=(etot12-etot22)/(2*aincr)
12641 !- end split gradient
12642 !            write (iout,*) "etot21",etot21," etot22",etot22
12643           endif
12644 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12645         c(j,i)=ddc(j)
12646           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12647           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12648           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12649           dc(j,i)=c(j,i+1)-c(j,i)
12650           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12651           dc_norm(j,i-1)=dcnorm_safe1(j)
12652           dc_norm(j,i)=dcnorm_safe2(j)
12653           dc_norm(j,i+nres)=dxnorm_safe(j)
12654         enddo
12655       do j=1,3
12656         c(j,i+nres)=ddx(j)+aincr
12657           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12658           call int_from_cart1(.false.)
12659           if (.not.split_ene) then
12660             call zerograd
12661             call etotal(energia1)
12662             etot1=energia1(0)
12663           else
12664 !- split gradient
12665             call etotal_long(energia1)
12666             etot11=energia1(0)
12667             call etotal_short(energia1)
12668             etot12=energia1(0)
12669           endif
12670 !- end split gradient
12671         c(j,i+nres)=ddx(j)-aincr
12672           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12673           call int_from_cart1(.false.)
12674           if (.not.split_ene) then
12675            call zerograd
12676            call etotal(energia1)
12677             etot2=energia1(0)
12678           ggg(j+3)=(etot1-etot2)/(2*aincr)
12679           else
12680 !- split gradient
12681             call etotal_long(energia1)
12682             etot21=energia1(0)
12683           ggg(j+3)=(etot11-etot21)/(2*aincr)
12684             call etotal_short(energia1)
12685             etot22=energia1(0)
12686           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12687 !- end split gradient
12688           endif
12689 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12690         c(j,i+nres)=ddx(j)
12691           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12692           dc_norm(j,i+nres)=dxnorm_safe(j)
12693           call int_from_cart1(.false.)
12694         enddo
12695       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12696          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12697         if (split_ene) then
12698           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12699          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12700          k=1,6)
12701          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12702          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12703          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12704         endif
12705       enddo
12706       return
12707       end subroutine check_ecartint
12708 #else
12709 !-----------------------------------------------------------------------------
12710       subroutine check_ecartint
12711 ! Check the gradient of the energy in Cartesian coordinates.
12712       use io_base, only: intout
12713 !      implicit real*8 (a-h,o-z)
12714 !      include 'DIMENSIONS'
12715 !      include 'COMMON.CONTROL'
12716 !      include 'COMMON.CHAIN'
12717 !      include 'COMMON.DERIV'
12718 !      include 'COMMON.IOUNITS'
12719 !      include 'COMMON.VAR'
12720 !      include 'COMMON.CONTACTS'
12721 !      include 'COMMON.MD'
12722 !      include 'COMMON.LOCAL'
12723 !      include 'COMMON.SPLITELE'
12724       use comm_srutu
12725 !el      integer :: icall
12726 !el      common /srutu/ icall
12727       real(kind=8),dimension(6) :: ggg,ggg1
12728       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12729       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12730       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12731       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12732       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12733       real(kind=8),dimension(0:n_ene) :: energia,energia1
12734       integer :: uiparm(1)
12735       real(kind=8) :: urparm(1)
12736 !EL      external fdum
12737       integer :: i,j,k,nf
12738       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12739                    etot21,etot22
12740       r_cut=2.0d0
12741       rlambd=0.3d0
12742       icg=1
12743       nf=0
12744       nfl=0
12745       call intout
12746 !      call intcartderiv
12747 !      call checkintcartgrad
12748       call zerograd
12749       aincr=1.0D-6
12750       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12751       nf=0
12752       icall=0
12753       call geom_to_var(nvar,x)
12754       if (.not.split_ene) then
12755         call etotal(energia)
12756         etot=energia(0)
12757 !el        call enerprint(energia)
12758         call cartgrad
12759         icall =1
12760         do i=1,nres
12761           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12762         enddo
12763         do j=1,3
12764           grad_s(j,0)=gcart(j,0)
12765         enddo
12766         do i=1,nres
12767           do j=1,3
12768             grad_s(j,i)=gcart(j,i)
12769 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12770
12771 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12772             grad_s(j+3,i)=gxcart(j,i)
12773           enddo
12774         enddo
12775       else
12776 !- split gradient check
12777         call zerograd
12778         call etotal_long(energia)
12779 !el        call enerprint(energia)
12780         call cartgrad
12781         icall =1
12782         do i=1,nres
12783           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12784           (gxcart(j,i),j=1,3)
12785         enddo
12786         do j=1,3
12787           grad_s(j,0)=gcart(j,0)
12788         enddo
12789         do i=1,nres
12790           do j=1,3
12791             grad_s(j,i)=gcart(j,i)
12792 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12793             grad_s(j+3,i)=gxcart(j,i)
12794           enddo
12795         enddo
12796         call zerograd
12797         call etotal_short(energia)
12798 !el        call enerprint(energia)
12799         call cartgrad
12800         icall =1
12801         do i=1,nres
12802           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12803           (gxcart(j,i),j=1,3)
12804         enddo
12805         do j=1,3
12806           grad_s1(j,0)=gcart(j,0)
12807         enddo
12808         do i=1,nres
12809           do j=1,3
12810             grad_s1(j,i)=gcart(j,i)
12811             grad_s1(j+3,i)=gxcart(j,i)
12812           enddo
12813         enddo
12814       endif
12815       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12816       do i=0,nres
12817         do j=1,3
12818         xx(j)=c(j,i+nres)
12819         ddc(j)=dc(j,i)
12820         ddx(j)=dc(j,i+nres)
12821           do k=1,3
12822             dcnorm_safe(k)=dc_norm(k,i)
12823             dxnorm_safe(k)=dc_norm(k,i+nres)
12824           enddo
12825         enddo
12826       do j=1,3
12827         dc(j,i)=ddc(j)+aincr
12828           call chainbuild_cart
12829 #ifdef MPI
12830 ! Broadcast the order to compute internal coordinates to the slaves.
12831 !          if (nfgtasks.gt.1)
12832 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12833 #endif
12834 !          call int_from_cart1(.false.)
12835           if (.not.split_ene) then
12836            call zerograd
12837             call etotal(energia1)
12838             etot1=energia1(0)
12839 !            call enerprint(energia1)
12840           else
12841 !- split gradient
12842             call etotal_long(energia1)
12843             etot11=energia1(0)
12844             call etotal_short(energia1)
12845             etot12=energia1(0)
12846 !            write (iout,*) "etot11",etot11," etot12",etot12
12847           endif
12848 !- end split gradient
12849 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12850         dc(j,i)=ddc(j)-aincr
12851           call chainbuild_cart
12852 !          call int_from_cart1(.false.)
12853           if (.not.split_ene) then
12854                   call zerograd
12855             call etotal(energia1)
12856             etot2=energia1(0)
12857           ggg(j)=(etot1-etot2)/(2*aincr)
12858           else
12859 !- split gradient
12860             call etotal_long(energia1)
12861             etot21=energia1(0)
12862           ggg(j)=(etot11-etot21)/(2*aincr)
12863             call etotal_short(energia1)
12864             etot22=energia1(0)
12865           ggg1(j)=(etot12-etot22)/(2*aincr)
12866 !- end split gradient
12867 !            write (iout,*) "etot21",etot21," etot22",etot22
12868           endif
12869 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12870         dc(j,i)=ddc(j)
12871           call chainbuild_cart
12872         enddo
12873       do j=1,3
12874         dc(j,i+nres)=ddx(j)+aincr
12875           call chainbuild_cart
12876 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12877 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12878 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12879 !          write (iout,*) "dxnormnorm",dsqrt(
12880 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12881 !          write (iout,*) "dxnormnormsafe",dsqrt(
12882 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12883 !          write (iout,*)
12884           if (.not.split_ene) then
12885             call zerograd
12886             call etotal(energia1)
12887             etot1=energia1(0)
12888           else
12889 !- split gradient
12890             call etotal_long(energia1)
12891             etot11=energia1(0)
12892             call etotal_short(energia1)
12893             etot12=energia1(0)
12894           endif
12895 !- end split gradient
12896 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12897         dc(j,i+nres)=ddx(j)-aincr
12898           call chainbuild_cart
12899 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12900 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12901 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12902 !          write (iout,*)
12903 !          write (iout,*) "dxnormnorm",dsqrt(
12904 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12905 !          write (iout,*) "dxnormnormsafe",dsqrt(
12906 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12907           if (.not.split_ene) then
12908             call zerograd
12909             call etotal(energia1)
12910             etot2=energia1(0)
12911           ggg(j+3)=(etot1-etot2)/(2*aincr)
12912           else
12913 !- split gradient
12914             call etotal_long(energia1)
12915             etot21=energia1(0)
12916           ggg(j+3)=(etot11-etot21)/(2*aincr)
12917             call etotal_short(energia1)
12918             etot22=energia1(0)
12919           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12920 !- end split gradient
12921           endif
12922 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12923         dc(j,i+nres)=ddx(j)
12924           call chainbuild_cart
12925         enddo
12926       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12927          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12928         if (split_ene) then
12929           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12930          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12931          k=1,6)
12932          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12933          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12934          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12935         endif
12936       enddo
12937       return
12938       end subroutine check_ecartint
12939 #endif
12940 !-----------------------------------------------------------------------------
12941       subroutine check_eint
12942 ! Check the gradient of energy in internal coordinates.
12943 !      implicit real*8 (a-h,o-z)
12944 !      include 'DIMENSIONS'
12945 !      include 'COMMON.CHAIN'
12946 !      include 'COMMON.DERIV'
12947 !      include 'COMMON.IOUNITS'
12948 !      include 'COMMON.VAR'
12949 !      include 'COMMON.GEO'
12950       use comm_srutu
12951 !el      integer :: icall
12952 !el      common /srutu/ icall
12953       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12954       integer :: uiparm(1)
12955       real(kind=8) :: urparm(1)
12956       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12957       character(len=6) :: key
12958 !EL      external fdum
12959       integer :: i,ii,nf
12960       real(kind=8) :: xi,aincr,etot,etot1,etot2
12961       call zerograd
12962       aincr=1.0D-7
12963       print '(a)','Calling CHECK_INT.'
12964       nf=0
12965       nfl=0
12966       icg=1
12967       call geom_to_var(nvar,x)
12968       call var_to_geom(nvar,x)
12969       call chainbuild
12970       icall=1
12971 !      print *,'ICG=',ICG
12972       call etotal(energia)
12973       etot = energia(0)
12974 !el      call enerprint(energia)
12975 !      print *,'ICG=',ICG
12976 #ifdef MPL
12977       if (MyID.ne.BossID) then
12978         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12979         nf=x(nvar+1)
12980         nfl=x(nvar+2)
12981         icg=x(nvar+3)
12982       endif
12983 #endif
12984       nf=1
12985       nfl=3
12986 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12987       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12988 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12989       icall=1
12990       do i=1,nvar
12991         xi=x(i)
12992         x(i)=xi-0.5D0*aincr
12993         call var_to_geom(nvar,x)
12994         call chainbuild
12995         call etotal(energia1)
12996         etot1=energia1(0)
12997         x(i)=xi+0.5D0*aincr
12998         call var_to_geom(nvar,x)
12999         call chainbuild
13000         call etotal(energia2)
13001         etot2=energia2(0)
13002         gg(i)=(etot2-etot1)/aincr
13003         write (iout,*) i,etot1,etot2
13004         x(i)=xi
13005       enddo
13006       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13007           '     RelDiff*100% '
13008       do i=1,nvar
13009         if (i.le.nphi) then
13010           ii=i
13011           key = ' phi'
13012         else if (i.le.nphi+ntheta) then
13013           ii=i-nphi
13014           key=' theta'
13015         else if (i.le.nphi+ntheta+nside) then
13016            ii=i-(nphi+ntheta)
13017            key=' alpha'
13018         else
13019            ii=i-(nphi+ntheta+nside)
13020            key=' omega'
13021         endif
13022         write (iout,'(i3,a,i3,3(1pd16.6))') &
13023        i,key,ii,gg(i),gana(i),&
13024        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13025       enddo
13026       return
13027       end subroutine check_eint
13028 !-----------------------------------------------------------------------------
13029 ! econstr_local.F
13030 !-----------------------------------------------------------------------------
13031       subroutine Econstr_back
13032 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13033 !      implicit real*8 (a-h,o-z)
13034 !      include 'DIMENSIONS'
13035 !      include 'COMMON.CONTROL'
13036 !      include 'COMMON.VAR'
13037 !      include 'COMMON.MD'
13038       use MD_data
13039 !#ifndef LANG0
13040 !      include 'COMMON.LANGEVIN'
13041 !#else
13042 !      include 'COMMON.LANGEVIN.lang0'
13043 !#endif
13044 !      include 'COMMON.CHAIN'
13045 !      include 'COMMON.DERIV'
13046 !      include 'COMMON.GEO'
13047 !      include 'COMMON.LOCAL'
13048 !      include 'COMMON.INTERACT'
13049 !      include 'COMMON.IOUNITS'
13050 !      include 'COMMON.NAMES'
13051 !      include 'COMMON.TIME1'
13052       integer :: i,j,ii,k
13053       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13054
13055       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13056       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13057       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13058
13059       Uconst_back=0.0d0
13060       do i=1,nres
13061         dutheta(i)=0.0d0
13062         dugamma(i)=0.0d0
13063         do j=1,3
13064           duscdiff(j,i)=0.0d0
13065           duscdiffx(j,i)=0.0d0
13066         enddo
13067       enddo
13068       do i=1,nfrag_back
13069         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13070 !
13071 ! Deviations from theta angles
13072 !
13073         utheta_i=0.0d0
13074         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13075           dtheta_i=theta(j)-thetaref(j)
13076           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13077           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13078         enddo
13079         utheta(i)=utheta_i/(ii-1)
13080 !
13081 ! Deviations from gamma angles
13082 !
13083         ugamma_i=0.0d0
13084         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13085           dgamma_i=pinorm(phi(j)-phiref(j))
13086 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13087           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13088           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13089 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13090         enddo
13091         ugamma(i)=ugamma_i/(ii-2)
13092 !
13093 ! Deviations from local SC geometry
13094 !
13095         uscdiff(i)=0.0d0
13096         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13097           dxx=xxtab(j)-xxref(j)
13098           dyy=yytab(j)-yyref(j)
13099           dzz=zztab(j)-zzref(j)
13100           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13101           do k=1,3
13102             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13103              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13104              (ii-1)
13105             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13106              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13107              (ii-1)
13108             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13109            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13110             /(ii-1)
13111           enddo
13112 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13113 !     &      xxref(j),yyref(j),zzref(j)
13114         enddo
13115         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13116 !        write (iout,*) i," uscdiff",uscdiff(i)
13117 !
13118 ! Put together deviations from local geometry
13119 !
13120         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13121           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13122 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13123 !     &   " uconst_back",uconst_back
13124         utheta(i)=dsqrt(utheta(i))
13125         ugamma(i)=dsqrt(ugamma(i))
13126         uscdiff(i)=dsqrt(uscdiff(i))
13127       enddo
13128       return
13129       end subroutine Econstr_back
13130 !-----------------------------------------------------------------------------
13131 ! energy_p_new-sep_barrier.F
13132 !-----------------------------------------------------------------------------
13133       real(kind=8) function sscale(r)
13134 !      include "COMMON.SPLITELE"
13135       real(kind=8) :: r,gamm
13136       if(r.lt.r_cut-rlamb) then
13137         sscale=1.0d0
13138       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13139         gamm=(r-(r_cut-rlamb))/rlamb
13140         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13141       else
13142         sscale=0d0
13143       endif
13144       return
13145       end function sscale
13146       real(kind=8) function sscale_grad(r)
13147 !      include "COMMON.SPLITELE"
13148       real(kind=8) :: r,gamm
13149       if(r.lt.r_cut-rlamb) then
13150         sscale_grad=0.0d0
13151       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13152         gamm=(r-(r_cut-rlamb))/rlamb
13153         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13154       else
13155         sscale_grad=0d0
13156       endif
13157       return
13158       end function sscale_grad
13159
13160 !!!!!!!!!! PBCSCALE
13161       real(kind=8) function sscale_ele(r)
13162 !      include "COMMON.SPLITELE"
13163       real(kind=8) :: r,gamm
13164       if(r.lt.r_cut_ele-rlamb_ele) then
13165         sscale_ele=1.0d0
13166       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13167         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13168         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13169       else
13170         sscale_ele=0d0
13171       endif
13172       return
13173       end function sscale_ele
13174
13175       real(kind=8)  function sscagrad_ele(r)
13176       real(kind=8) :: r,gamm
13177 !      include "COMMON.SPLITELE"
13178       if(r.lt.r_cut_ele-rlamb_ele) then
13179         sscagrad_ele=0.0d0
13180       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13181         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13182         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13183       else
13184         sscagrad_ele=0.0d0
13185       endif
13186       return
13187       end function sscagrad_ele
13188       real(kind=8) function sscalelip(r)
13189       real(kind=8) r,gamm
13190         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13191       return
13192       end function sscalelip
13193 !C-----------------------------------------------------------------------
13194       real(kind=8) function sscagradlip(r)
13195       real(kind=8) r,gamm
13196         sscagradlip=r*(6.0d0*r-6.0d0)
13197       return
13198       end function sscagradlip
13199
13200 !!!!!!!!!!!!!!!
13201 !-----------------------------------------------------------------------------
13202       subroutine elj_long(evdw)
13203 !
13204 ! This subroutine calculates the interaction energy of nonbonded side chains
13205 ! assuming the LJ potential of interaction.
13206 !
13207 !      implicit real*8 (a-h,o-z)
13208 !      include 'DIMENSIONS'
13209 !      include 'COMMON.GEO'
13210 !      include 'COMMON.VAR'
13211 !      include 'COMMON.LOCAL'
13212 !      include 'COMMON.CHAIN'
13213 !      include 'COMMON.DERIV'
13214 !      include 'COMMON.INTERACT'
13215 !      include 'COMMON.TORSION'
13216 !      include 'COMMON.SBRIDGE'
13217 !      include 'COMMON.NAMES'
13218 !      include 'COMMON.IOUNITS'
13219 !      include 'COMMON.CONTACTS'
13220       real(kind=8),parameter :: accur=1.0d-10
13221       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13222 !el local variables
13223       integer :: i,iint,j,k,itypi,itypi1,itypj
13224       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13225       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13226                       sslipj,ssgradlipj,aa,bb
13227 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13228       evdw=0.0D0
13229       do i=iatsc_s,iatsc_e
13230         itypi=itype(i,1)
13231         if (itypi.eq.ntyp1) cycle
13232         itypi1=itype(i+1,1)
13233         xi=c(1,nres+i)
13234         yi=c(2,nres+i)
13235         zi=c(3,nres+i)
13236         call to_box(xi,yi,zi)
13237         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
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             call to_box(xj,yj,zj)
13251             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13252             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13253              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13254             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13255              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13256             xj=boxshift(xj-xi,boxxsize)
13257             yj=boxshift(yj-yi,boxysize)
13258             zj=boxshift(zj-zi,boxzsize)
13259             rij=xj*xj+yj*yj+zj*zj
13260             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13261             if (sss.lt.1.0d0) then
13262               rrij=1.0D0/rij
13263               eps0ij=eps(itypi,itypj)
13264               fac=rrij**expon2
13265               e1=fac*fac*aa_aq(itypi,itypj)
13266               e2=fac*bb_aq(itypi,itypj)
13267               evdwij=e1+e2
13268               evdw=evdw+(1.0d0-sss)*evdwij
13269 !
13270 ! Calculate the components of the gradient in DC and X
13271 !
13272               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13273               gg(1)=xj*fac
13274               gg(2)=yj*fac
13275               gg(3)=zj*fac
13276               do k=1,3
13277                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13278                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13279                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13280                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13281               enddo
13282             endif
13283           enddo      ! j
13284         enddo        ! iint
13285       enddo          ! i
13286       do i=1,nct
13287         do j=1,3
13288           gvdwc(j,i)=expon*gvdwc(j,i)
13289           gvdwx(j,i)=expon*gvdwx(j,i)
13290         enddo
13291       enddo
13292 !******************************************************************************
13293 !
13294 !                              N O T E !!!
13295 !
13296 ! To save time, the factor of EXPON has been extracted from ALL components
13297 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13298 ! use!
13299 !
13300 !******************************************************************************
13301       return
13302       end subroutine elj_long
13303 !-----------------------------------------------------------------------------
13304       subroutine elj_short(evdw)
13305 !
13306 ! This subroutine calculates the interaction energy of nonbonded side chains
13307 ! assuming the LJ potential of interaction.
13308 !
13309 !      implicit real*8 (a-h,o-z)
13310 !      include 'DIMENSIONS'
13311 !      include 'COMMON.GEO'
13312 !      include 'COMMON.VAR'
13313 !      include 'COMMON.LOCAL'
13314 !      include 'COMMON.CHAIN'
13315 !      include 'COMMON.DERIV'
13316 !      include 'COMMON.INTERACT'
13317 !      include 'COMMON.TORSION'
13318 !      include 'COMMON.SBRIDGE'
13319 !      include 'COMMON.NAMES'
13320 !      include 'COMMON.IOUNITS'
13321 !      include 'COMMON.CONTACTS'
13322       real(kind=8),parameter :: accur=1.0d-10
13323       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13324 !el local variables
13325       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13326       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13327       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13328                       sslipj,ssgradlipj
13329 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13330       evdw=0.0D0
13331       do i=iatsc_s,iatsc_e
13332         itypi=itype(i,1)
13333         if (itypi.eq.ntyp1) cycle
13334         itypi1=itype(i+1,1)
13335         xi=c(1,nres+i)
13336         yi=c(2,nres+i)
13337         zi=c(3,nres+i)
13338         call to_box(xi,yi,zi)
13339         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13340 ! Change 12/1/95
13341         num_conti=0
13342 !
13343 ! Calculate SC interaction energy.
13344 !
13345         do iint=1,nint_gr(i)
13346 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13347 !d   &                  'iend=',iend(i,iint)
13348           do j=istart(i,iint),iend(i,iint)
13349             itypj=itype(j,1)
13350             if (itypj.eq.ntyp1) cycle
13351             xj=c(1,nres+j)-xi
13352             yj=c(2,nres+j)-yi
13353             zj=c(3,nres+j)-zi
13354 ! Change 12/1/95 to calculate four-body interactions
13355             rij=xj*xj+yj*yj+zj*zj
13356             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13357             if (sss.gt.0.0d0) then
13358               rrij=1.0D0/rij
13359               eps0ij=eps(itypi,itypj)
13360               fac=rrij**expon2
13361               e1=fac*fac*aa_aq(itypi,itypj)
13362               e2=fac*bb_aq(itypi,itypj)
13363               evdwij=e1+e2
13364               evdw=evdw+sss*evdwij
13365 !
13366 ! Calculate the components of the gradient in DC and X
13367 !
13368               fac=-rrij*(e1+evdwij)*sss
13369               gg(1)=xj*fac
13370               gg(2)=yj*fac
13371               gg(3)=zj*fac
13372               do k=1,3
13373                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13374                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13375                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13376                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13377               enddo
13378             endif
13379           enddo      ! j
13380         enddo        ! iint
13381       enddo          ! i
13382       do i=1,nct
13383         do j=1,3
13384           gvdwc(j,i)=expon*gvdwc(j,i)
13385           gvdwx(j,i)=expon*gvdwx(j,i)
13386         enddo
13387       enddo
13388 !******************************************************************************
13389 !
13390 !                              N O T E !!!
13391 !
13392 ! To save time, the factor of EXPON has been extracted from ALL components
13393 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13394 ! use!
13395 !
13396 !******************************************************************************
13397       return
13398       end subroutine elj_short
13399 !-----------------------------------------------------------------------------
13400       subroutine eljk_long(evdw)
13401 !
13402 ! This subroutine calculates the interaction energy of nonbonded side chains
13403 ! assuming the LJK potential of interaction.
13404 !
13405 !      implicit real*8 (a-h,o-z)
13406 !      include 'DIMENSIONS'
13407 !      include 'COMMON.GEO'
13408 !      include 'COMMON.VAR'
13409 !      include 'COMMON.LOCAL'
13410 !      include 'COMMON.CHAIN'
13411 !      include 'COMMON.DERIV'
13412 !      include 'COMMON.INTERACT'
13413 !      include 'COMMON.IOUNITS'
13414 !      include 'COMMON.NAMES'
13415       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13416       logical :: scheck
13417 !el local variables
13418       integer :: i,iint,j,k,itypi,itypi1,itypj
13419       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13420                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13421 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13422       evdw=0.0D0
13423       do i=iatsc_s,iatsc_e
13424         itypi=itype(i,1)
13425         if (itypi.eq.ntyp1) cycle
13426         itypi1=itype(i+1,1)
13427         xi=c(1,nres+i)
13428         yi=c(2,nres+i)
13429         zi=c(3,nres+i)
13430 !
13431 ! Calculate SC interaction energy.
13432 !
13433         do iint=1,nint_gr(i)
13434           do j=istart(i,iint),iend(i,iint)
13435             itypj=itype(j,1)
13436             if (itypj.eq.ntyp1) cycle
13437             xj=c(1,nres+j)-xi
13438             yj=c(2,nres+j)-yi
13439             zj=c(3,nres+j)-zi
13440             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13441             fac_augm=rrij**expon
13442             e_augm=augm(itypi,itypj)*fac_augm
13443             r_inv_ij=dsqrt(rrij)
13444             rij=1.0D0/r_inv_ij
13445             sss=sscale(rij/sigma(itypi,itypj))
13446             if (sss.lt.1.0d0) then
13447               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13448               fac=r_shift_inv**expon
13449               e1=fac*fac*aa_aq(itypi,itypj)
13450               e2=fac*bb_aq(itypi,itypj)
13451               evdwij=e_augm+e1+e2
13452 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13453 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13454 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13455 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13456 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13457 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13458 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13459               evdw=evdw+(1.0d0-sss)*evdwij
13460 !
13461 ! Calculate the components of the gradient in DC and X
13462 !
13463               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13464               fac=fac*(1.0d0-sss)
13465               gg(1)=xj*fac
13466               gg(2)=yj*fac
13467               gg(3)=zj*fac
13468               do k=1,3
13469                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13470                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13471                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13472                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13473               enddo
13474             endif
13475           enddo      ! j
13476         enddo        ! iint
13477       enddo          ! i
13478       do i=1,nct
13479         do j=1,3
13480           gvdwc(j,i)=expon*gvdwc(j,i)
13481           gvdwx(j,i)=expon*gvdwx(j,i)
13482         enddo
13483       enddo
13484       return
13485       end subroutine eljk_long
13486 !-----------------------------------------------------------------------------
13487       subroutine eljk_short(evdw)
13488 !
13489 ! This subroutine calculates the interaction energy of nonbonded side chains
13490 ! assuming the LJK potential of interaction.
13491 !
13492 !      implicit real*8 (a-h,o-z)
13493 !      include 'DIMENSIONS'
13494 !      include 'COMMON.GEO'
13495 !      include 'COMMON.VAR'
13496 !      include 'COMMON.LOCAL'
13497 !      include 'COMMON.CHAIN'
13498 !      include 'COMMON.DERIV'
13499 !      include 'COMMON.INTERACT'
13500 !      include 'COMMON.IOUNITS'
13501 !      include 'COMMON.NAMES'
13502       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13503       logical :: scheck
13504 !el local variables
13505       integer :: i,iint,j,k,itypi,itypi1,itypj
13506       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13507                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
13508                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
13509 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13510       evdw=0.0D0
13511       do i=iatsc_s,iatsc_e
13512         itypi=itype(i,1)
13513         if (itypi.eq.ntyp1) cycle
13514         itypi1=itype(i+1,1)
13515         xi=c(1,nres+i)
13516         yi=c(2,nres+i)
13517         zi=c(3,nres+i)
13518         call to_box(xi,yi,zi)
13519         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13520 !
13521 ! Calculate SC interaction energy.
13522 !
13523         do iint=1,nint_gr(i)
13524           do j=istart(i,iint),iend(i,iint)
13525             itypj=itype(j,1)
13526             if (itypj.eq.ntyp1) cycle
13527             xj=c(1,nres+j)-xi
13528             yj=c(2,nres+j)-yi
13529             zj=c(3,nres+j)-zi
13530             call to_box(xj,yj,zj)
13531             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13532             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13533              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13534             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13535              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13536             xj=boxshift(xj-xi,boxxsize)
13537             yj=boxshift(yj-yi,boxysize)
13538             zj=boxshift(zj-zi,boxzsize)
13539             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13540             fac_augm=rrij**expon
13541             e_augm=augm(itypi,itypj)*fac_augm
13542             r_inv_ij=dsqrt(rrij)
13543             rij=1.0D0/r_inv_ij
13544             sss=sscale(rij/sigma(itypi,itypj))
13545             if (sss.gt.0.0d0) then
13546               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13547               fac=r_shift_inv**expon
13548               e1=fac*fac*aa_aq(itypi,itypj)
13549               e2=fac*bb_aq(itypi,itypj)
13550               evdwij=e_augm+e1+e2
13551 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13552 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13553 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13554 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13555 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13556 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13557 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13558               evdw=evdw+sss*evdwij
13559 !
13560 ! Calculate the components of the gradient in DC and X
13561 !
13562               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13563               fac=fac*sss
13564               gg(1)=xj*fac
13565               gg(2)=yj*fac
13566               gg(3)=zj*fac
13567               do k=1,3
13568                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13569                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13570                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13571                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13572               enddo
13573             endif
13574           enddo      ! j
13575         enddo        ! iint
13576       enddo          ! i
13577       do i=1,nct
13578         do j=1,3
13579           gvdwc(j,i)=expon*gvdwc(j,i)
13580           gvdwx(j,i)=expon*gvdwx(j,i)
13581         enddo
13582       enddo
13583       return
13584       end subroutine eljk_short
13585 !-----------------------------------------------------------------------------
13586        subroutine ebp_long(evdw)
13587 ! This subroutine calculates the interaction energy of nonbonded side chains
13588 ! assuming the Berne-Pechukas potential of interaction.
13589 !
13590        use calc_data
13591 !      implicit real*8 (a-h,o-z)
13592 !      include 'DIMENSIONS'
13593 !      include 'COMMON.GEO'
13594 !      include 'COMMON.VAR'
13595 !      include 'COMMON.LOCAL'
13596 !      include 'COMMON.CHAIN'
13597 !      include 'COMMON.DERIV'
13598 !      include 'COMMON.NAMES'
13599 !      include 'COMMON.INTERACT'
13600 !      include 'COMMON.IOUNITS'
13601 !      include 'COMMON.CALC'
13602        use comm_srutu
13603 !el      integer :: icall
13604 !el      common /srutu/ icall
13605 !     double precision rrsave(maxdim)
13606         logical :: lprn
13607 !el local variables
13608         integer :: iint,itypi,itypi1,itypj
13609         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
13610                         sslipj,ssgradlipj,aa,bb
13611         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13612         evdw=0.0D0
13613 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13614         evdw=0.0D0
13615 !     if (icall.eq.0) then
13616 !       lprn=.true.
13617 !     else
13618       lprn=.false.
13619 !     endif
13620 !el      ind=0
13621       do i=iatsc_s,iatsc_e
13622       itypi=itype(i,1)
13623       if (itypi.eq.ntyp1) cycle
13624       itypi1=itype(i+1,1)
13625       xi=c(1,nres+i)
13626       yi=c(2,nres+i)
13627       zi=c(3,nres+i)
13628         call to_box(xi,yi,zi)
13629         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13630       dxi=dc_norm(1,nres+i)
13631       dyi=dc_norm(2,nres+i)
13632       dzi=dc_norm(3,nres+i)
13633 !        dsci_inv=dsc_inv(itypi)
13634       dsci_inv=vbld_inv(i+nres)
13635 !
13636 ! Calculate SC interaction energy.
13637 !
13638       do iint=1,nint_gr(i)
13639       do j=istart(i,iint),iend(i,iint)
13640 !el            ind=ind+1
13641       itypj=itype(j,1)
13642       if (itypj.eq.ntyp1) cycle
13643 !            dscj_inv=dsc_inv(itypj)
13644       dscj_inv=vbld_inv(j+nres)
13645 chi1=chi(itypi,itypj)
13646 chi2=chi(itypj,itypi)
13647 chi12=chi1*chi2
13648 chip1=chip(itypi)
13649       alf1=alp(itypi)
13650       alf2=alp(itypj)
13651       alf12=0.5D0*(alf1+alf2)
13652         xj=c(1,nres+j)-xi
13653         yj=c(2,nres+j)-yi
13654         zj=c(3,nres+j)-zi
13655             call to_box(xj,yj,zj)
13656             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13657             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13658              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13659             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13660              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13661             xj=boxshift(xj-xi,boxxsize)
13662             yj=boxshift(yj-yi,boxysize)
13663             zj=boxshift(zj-zi,boxzsize)
13664         dxj=dc_norm(1,nres+j)
13665         dyj=dc_norm(2,nres+j)
13666         dzj=dc_norm(3,nres+j)
13667         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13668         rij=dsqrt(rrij)
13669       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13670
13671         if (sss.lt.1.0d0) then
13672
13673         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13674         call sc_angular
13675         ! Calculate whole angle-dependent part of epsilon and contributions
13676         ! to its derivatives
13677         fac=(rrij*sigsq)**expon2
13678         e1=fac*fac*aa_aq(itypi,itypj)
13679         e2=fac*bb_aq(itypi,itypj)
13680       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13681         eps2der=evdwij*eps3rt
13682         eps3der=evdwij*eps2rt
13683         evdwij=evdwij*eps2rt*eps3rt
13684       evdw=evdw+evdwij*(1.0d0-sss)
13685         if (lprn) then
13686         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13687       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13688         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13689         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13690         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13691         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13692         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13693         !d     &          evdwij
13694         endif
13695         ! Calculate gradient components.
13696         e1=e1*eps1*eps2rt**2*eps3rt**2
13697       fac=-expon*(e1+evdwij)
13698         sigder=fac/sigsq
13699         fac=rrij*fac
13700         ! Calculate radial part of the gradient
13701         gg(1)=xj*fac
13702         gg(2)=yj*fac
13703         gg(3)=zj*fac
13704         ! Calculate the angular part of the gradient and sum add the contributions
13705         ! to the appropriate components of the Cartesian gradient.
13706       call sc_grad_scale(1.0d0-sss)
13707         endif
13708         enddo      ! j
13709         enddo        ! iint
13710         enddo          ! i
13711         !     stop
13712         return
13713         end subroutine ebp_long
13714         !-----------------------------------------------------------------------------
13715       subroutine ebp_short(evdw)
13716         !
13717         ! This subroutine calculates the interaction energy of nonbonded side chains
13718         ! assuming the Berne-Pechukas potential of interaction.
13719         !
13720         use calc_data
13721 !      implicit real*8 (a-h,o-z)
13722         !      include 'DIMENSIONS'
13723         !      include 'COMMON.GEO'
13724         !      include 'COMMON.VAR'
13725         !      include 'COMMON.LOCAL'
13726         !      include 'COMMON.CHAIN'
13727         !      include 'COMMON.DERIV'
13728         !      include 'COMMON.NAMES'
13729         !      include 'COMMON.INTERACT'
13730         !      include 'COMMON.IOUNITS'
13731         !      include 'COMMON.CALC'
13732         use comm_srutu
13733         !el      integer :: icall
13734         !el      common /srutu/ icall
13735 !     double precision rrsave(maxdim)
13736         logical :: lprn
13737         !el local variables
13738         integer :: iint,itypi,itypi1,itypj
13739         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13740         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
13741         sslipi,ssgradlipi,sslipj,ssgradlipj
13742         evdw=0.0D0
13743         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13744         evdw=0.0D0
13745         !     if (icall.eq.0) then
13746         !       lprn=.true.
13747         !     else
13748         lprn=.false.
13749         !     endif
13750         !el      ind=0
13751         do i=iatsc_s,iatsc_e
13752       itypi=itype(i,1)
13753         if (itypi.eq.ntyp1) cycle
13754         itypi1=itype(i+1,1)
13755         xi=c(1,nres+i)
13756         yi=c(2,nres+i)
13757         zi=c(3,nres+i)
13758         call to_box(xi,yi,zi)
13759       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13760
13761         dxi=dc_norm(1,nres+i)
13762         dyi=dc_norm(2,nres+i)
13763         dzi=dc_norm(3,nres+i)
13764         !        dsci_inv=dsc_inv(itypi)
13765       dsci_inv=vbld_inv(i+nres)
13766         !
13767         ! Calculate SC interaction energy.
13768         !
13769         do iint=1,nint_gr(i)
13770       do j=istart(i,iint),iend(i,iint)
13771         !el            ind=ind+1
13772       itypj=itype(j,1)
13773         if (itypj.eq.ntyp1) cycle
13774         !            dscj_inv=dsc_inv(itypj)
13775         dscj_inv=vbld_inv(j+nres)
13776         chi1=chi(itypi,itypj)
13777       chi2=chi(itypj,itypi)
13778         chi12=chi1*chi2
13779         chip1=chip(itypi)
13780       chip2=chip(itypj)
13781         chip12=chip1*chip2
13782         alf1=alp(itypi)
13783         alf2=alp(itypj)
13784       alf12=0.5D0*(alf1+alf2)
13785         xj=c(1,nres+j)-xi
13786         yj=c(2,nres+j)-yi
13787         zj=c(3,nres+j)-zi
13788         call to_box(xj,yj,zj)
13789       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13790         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13791         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13792         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13793              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13794             xj=boxshift(xj-xi,boxxsize)
13795             yj=boxshift(yj-yi,boxysize)
13796             zj=boxshift(zj-zi,boxzsize)
13797             dxj=dc_norm(1,nres+j)
13798             dyj=dc_norm(2,nres+j)
13799             dzj=dc_norm(3,nres+j)
13800             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13801             rij=dsqrt(rrij)
13802             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13803
13804             if (sss.gt.0.0d0) then
13805
13806 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13807               call sc_angular
13808 ! Calculate whole angle-dependent part of epsilon and contributions
13809 ! to its derivatives
13810               fac=(rrij*sigsq)**expon2
13811               e1=fac*fac*aa_aq(itypi,itypj)
13812               e2=fac*bb_aq(itypi,itypj)
13813               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13814               eps2der=evdwij*eps3rt
13815               eps3der=evdwij*eps2rt
13816               evdwij=evdwij*eps2rt*eps3rt
13817               evdw=evdw+evdwij*sss
13818               if (lprn) then
13819               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13820               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13821 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13822 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13823 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13824 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13825 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13826 !d     &          evdwij
13827               endif
13828 ! Calculate gradient components.
13829               e1=e1*eps1*eps2rt**2*eps3rt**2
13830               fac=-expon*(e1+evdwij)
13831               sigder=fac/sigsq
13832               fac=rrij*fac
13833 ! Calculate radial part of the gradient
13834               gg(1)=xj*fac
13835               gg(2)=yj*fac
13836               gg(3)=zj*fac
13837 ! Calculate the angular part of the gradient and sum add the contributions
13838 ! to the appropriate components of the Cartesian gradient.
13839               call sc_grad_scale(sss)
13840             endif
13841           enddo      ! j
13842         enddo        ! iint
13843       enddo          ! i
13844 !     stop
13845       return
13846       end subroutine ebp_short
13847 !-----------------------------------------------------------------------------
13848       subroutine egb_long(evdw)
13849 !
13850 ! This subroutine calculates the interaction energy of nonbonded side chains
13851 ! assuming the Gay-Berne potential of interaction.
13852 !
13853       use calc_data
13854 !      implicit real*8 (a-h,o-z)
13855 !      include 'DIMENSIONS'
13856 !      include 'COMMON.GEO'
13857 !      include 'COMMON.VAR'
13858 !      include 'COMMON.LOCAL'
13859 !      include 'COMMON.CHAIN'
13860 !      include 'COMMON.DERIV'
13861 !      include 'COMMON.NAMES'
13862 !      include 'COMMON.INTERACT'
13863 !      include 'COMMON.IOUNITS'
13864 !      include 'COMMON.CALC'
13865 !      include 'COMMON.CONTROL'
13866       logical :: lprn
13867 !el local variables
13868       integer :: iint,itypi,itypi1,itypj,subchap
13869       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13870       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13871       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13872                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13873                     ssgradlipi,ssgradlipj
13874
13875
13876       evdw=0.0D0
13877 !cccc      energy_dec=.false.
13878 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13879       evdw=0.0D0
13880       lprn=.false.
13881 !     if (icall.eq.0) lprn=.false.
13882 !el      ind=0
13883       do i=iatsc_s,iatsc_e
13884         itypi=itype(i,1)
13885         if (itypi.eq.ntyp1) cycle
13886         itypi1=itype(i+1,1)
13887         xi=c(1,nres+i)
13888         yi=c(2,nres+i)
13889         zi=c(3,nres+i)
13890         call to_box(xi,yi,zi)
13891         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13892         dxi=dc_norm(1,nres+i)
13893         dyi=dc_norm(2,nres+i)
13894         dzi=dc_norm(3,nres+i)
13895 !        dsci_inv=dsc_inv(itypi)
13896         dsci_inv=vbld_inv(i+nres)
13897 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13898 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13899 !
13900 ! Calculate SC interaction energy.
13901 !
13902         do iint=1,nint_gr(i)
13903           do j=istart(i,iint),iend(i,iint)
13904             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13905 !              call dyn_ssbond_ene(i,j,evdwij)
13906 !              evdw=evdw+evdwij
13907 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13908 !                              'evdw',i,j,evdwij,' ss'
13909 !              if (energy_dec) write (iout,*) &
13910 !                              'evdw',i,j,evdwij,' ss'
13911 !             do k=j+1,iend(i,iint)
13912 !C search over all next residues
13913 !              if (dyn_ss_mask(k)) then
13914 !C check if they are cysteins
13915 !C              write(iout,*) 'k=',k
13916
13917 !c              write(iout,*) "PRZED TRI", evdwij
13918 !               evdwij_przed_tri=evdwij
13919 !              call triple_ssbond_ene(i,j,k,evdwij)
13920 !c               if(evdwij_przed_tri.ne.evdwij) then
13921 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13922 !c               endif
13923
13924 !c              write(iout,*) "PO TRI", evdwij
13925 !C call the energy function that removes the artifical triple disulfide
13926 !C bond the soubroutine is located in ssMD.F
13927 !              evdw=evdw+evdwij
13928               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13929                             'evdw',i,j,evdwij,'tss'
13930 !              endif!dyn_ss_mask(k)
13931 !             enddo! k
13932
13933             ELSE
13934 !el            ind=ind+1
13935             itypj=itype(j,1)
13936             if (itypj.eq.ntyp1) cycle
13937 !            dscj_inv=dsc_inv(itypj)
13938             dscj_inv=vbld_inv(j+nres)
13939 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13940 !     &       1.0d0/vbld(j+nres)
13941 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13942             sig0ij=sigma(itypi,itypj)
13943             chi1=chi(itypi,itypj)
13944             chi2=chi(itypj,itypi)
13945             chi12=chi1*chi2
13946             chip1=chip(itypi)
13947             chip2=chip(itypj)
13948             chip12=chip1*chip2
13949             alf1=alp(itypi)
13950             alf2=alp(itypj)
13951             alf12=0.5D0*(alf1+alf2)
13952             xj=c(1,nres+j)
13953             yj=c(2,nres+j)
13954             zj=c(3,nres+j)
13955 ! Searching for nearest neighbour
13956             call to_box(xj,yj,zj)
13957             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13958             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13959              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13960             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13961              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13962             xj=boxshift(xj-xi,boxxsize)
13963             yj=boxshift(yj-yi,boxysize)
13964             zj=boxshift(zj-zi,boxzsize)
13965             dxj=dc_norm(1,nres+j)
13966             dyj=dc_norm(2,nres+j)
13967             dzj=dc_norm(3,nres+j)
13968             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13969             rij=dsqrt(rrij)
13970             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13971             sss_ele_cut=sscale_ele(1.0d0/(rij))
13972             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
13973             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13974             if (sss_ele_cut.le.0.0) cycle
13975             if (sss.lt.1.0d0) then
13976
13977 ! Calculate angle-dependent terms of energy and contributions to their
13978 ! derivatives.
13979               call sc_angular
13980               sigsq=1.0D0/sigsq
13981               sig=sig0ij*dsqrt(sigsq)
13982               rij_shift=1.0D0/rij-sig+sig0ij
13983 ! for diagnostics; uncomment
13984 !              rij_shift=1.2*sig0ij
13985 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13986               if (rij_shift.le.0.0D0) then
13987                 evdw=1.0D20
13988 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13989 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13990 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13991                 return
13992               endif
13993               sigder=-sig*sigsq
13994 !---------------------------------------------------------------
13995               rij_shift=1.0D0/rij_shift
13996               fac=rij_shift**expon
13997               e1=fac*fac*aa
13998               e2=fac*bb
13999               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14000               eps2der=evdwij*eps3rt
14001               eps3der=evdwij*eps2rt
14002 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14003 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14004               evdwij=evdwij*eps2rt*eps3rt
14005               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14006               if (lprn) then
14007               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14008               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14009               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14010                 restyp(itypi,1),i,restyp(itypj,1),j,&
14011                 epsi,sigm,chi1,chi2,chip1,chip2,&
14012                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14013                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14014                 evdwij
14015               endif
14016
14017               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14018                               'evdw',i,j,evdwij
14019 !              if (energy_dec) write (iout,*) &
14020 !                              'evdw',i,j,evdwij,"egb_long"
14021
14022 ! Calculate gradient components.
14023               e1=e1*eps1*eps2rt**2*eps3rt**2
14024               fac=-expon*(e1+evdwij)*rij_shift
14025               sigder=fac*sigder
14026               fac=rij*fac
14027               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14028               *rij-sss_grad/(1.0-sss)*rij  &
14029             /sigmaii(itypi,itypj))
14030 !              fac=0.0d0
14031 ! Calculate the radial part of the gradient
14032               gg(1)=xj*fac
14033               gg(2)=yj*fac
14034               gg(3)=zj*fac
14035 ! Calculate angular part of the gradient.
14036               call sc_grad_scale(1.0d0-sss)
14037             ENDIF    !mask_dyn_ss
14038             endif
14039           enddo      ! j
14040         enddo        ! iint
14041       enddo          ! i
14042 !      write (iout,*) "Number of loop steps in EGB:",ind
14043 !ccc      energy_dec=.false.
14044       return
14045       end subroutine egb_long
14046 !-----------------------------------------------------------------------------
14047       subroutine egb_short(evdw)
14048 !
14049 ! This subroutine calculates the interaction energy of nonbonded side chains
14050 ! assuming the Gay-Berne potential of interaction.
14051 !
14052       use calc_data
14053 !      implicit real*8 (a-h,o-z)
14054 !      include 'DIMENSIONS'
14055 !      include 'COMMON.GEO'
14056 !      include 'COMMON.VAR'
14057 !      include 'COMMON.LOCAL'
14058 !      include 'COMMON.CHAIN'
14059 !      include 'COMMON.DERIV'
14060 !      include 'COMMON.NAMES'
14061 !      include 'COMMON.INTERACT'
14062 !      include 'COMMON.IOUNITS'
14063 !      include 'COMMON.CALC'
14064 !      include 'COMMON.CONTROL'
14065       logical :: lprn
14066 !el local variables
14067       integer :: iint,itypi,itypi1,itypj,subchap
14068       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14069       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14070       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14071                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14072                     ssgradlipi,ssgradlipj
14073       evdw=0.0D0
14074 !cccc      energy_dec=.false.
14075 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14076       evdw=0.0D0
14077       lprn=.false.
14078 !     if (icall.eq.0) lprn=.false.
14079 !el      ind=0
14080       do i=iatsc_s,iatsc_e
14081         itypi=itype(i,1)
14082         if (itypi.eq.ntyp1) cycle
14083         itypi1=itype(i+1,1)
14084         xi=c(1,nres+i)
14085         yi=c(2,nres+i)
14086         zi=c(3,nres+i)
14087         call to_box(xi,yi,zi)
14088         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14089
14090         dxi=dc_norm(1,nres+i)
14091         dyi=dc_norm(2,nres+i)
14092         dzi=dc_norm(3,nres+i)
14093 !        dsci_inv=dsc_inv(itypi)
14094         dsci_inv=vbld_inv(i+nres)
14095
14096         dxi=dc_norm(1,nres+i)
14097         dyi=dc_norm(2,nres+i)
14098         dzi=dc_norm(3,nres+i)
14099 !        dsci_inv=dsc_inv(itypi)
14100         dsci_inv=vbld_inv(i+nres)
14101         do iint=1,nint_gr(i)
14102           do j=istart(i,iint),iend(i,iint)
14103             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14104               call dyn_ssbond_ene(i,j,evdwij)
14105               evdw=evdw+evdwij
14106               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14107                               'evdw',i,j,evdwij,' ss'
14108              do k=j+1,iend(i,iint)
14109 !C search over all next residues
14110               if (dyn_ss_mask(k)) then
14111 !C check if they are cysteins
14112 !C              write(iout,*) 'k=',k
14113
14114 !c              write(iout,*) "PRZED TRI", evdwij
14115 !               evdwij_przed_tri=evdwij
14116               call triple_ssbond_ene(i,j,k,evdwij)
14117 !c               if(evdwij_przed_tri.ne.evdwij) then
14118 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14119 !c               endif
14120
14121 !c              write(iout,*) "PO TRI", evdwij
14122 !C call the energy function that removes the artifical triple disulfide
14123 !C bond the soubroutine is located in ssMD.F
14124               evdw=evdw+evdwij
14125               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14126                             'evdw',i,j,evdwij,'tss'
14127               endif!dyn_ss_mask(k)
14128              enddo! k
14129             ELSE
14130
14131 !          typj=itype(j,1)
14132             if (itypj.eq.ntyp1) cycle
14133 !            dscj_inv=dsc_inv(itypj)
14134             dscj_inv=vbld_inv(j+nres)
14135             dscj_inv=dsc_inv(itypj)
14136 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14137 !     &       1.0d0/vbld(j+nres)
14138 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14139             sig0ij=sigma(itypi,itypj)
14140             chi1=chi(itypi,itypj)
14141             chi2=chi(itypj,itypi)
14142             chi12=chi1*chi2
14143             chip1=chip(itypi)
14144             chip2=chip(itypj)
14145             chip12=chip1*chip2
14146             alf1=alp(itypi)
14147             alf2=alp(itypj)
14148             alf12=0.5D0*(alf1+alf2)
14149 !            xj=c(1,nres+j)-xi
14150 !            yj=c(2,nres+j)-yi
14151 !            zj=c(3,nres+j)-zi
14152             xj=c(1,nres+j)
14153             yj=c(2,nres+j)
14154             zj=c(3,nres+j)
14155 ! Searching for nearest neighbour
14156             call to_box(xj,yj,zj)
14157             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14158             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14159              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14160             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14161              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14162             xj=boxshift(xj-xi,boxxsize)
14163             yj=boxshift(yj-yi,boxysize)
14164             zj=boxshift(zj-zi,boxzsize)
14165             dxj=dc_norm(1,nres+j)
14166             dyj=dc_norm(2,nres+j)
14167             dzj=dc_norm(3,nres+j)
14168             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14169             rij=dsqrt(rrij)
14170             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14171             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14172             sss_ele_cut=sscale_ele(1.0d0/(rij))
14173             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14174             if (sss_ele_cut.le.0.0) cycle
14175
14176             if (sss.gt.0.0d0) then
14177
14178 ! Calculate angle-dependent terms of energy and contributions to their
14179 ! derivatives.
14180               call sc_angular
14181               sigsq=1.0D0/sigsq
14182               sig=sig0ij*dsqrt(sigsq)
14183               rij_shift=1.0D0/rij-sig+sig0ij
14184 ! for diagnostics; uncomment
14185 !              rij_shift=1.2*sig0ij
14186 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14187               if (rij_shift.le.0.0D0) then
14188                 evdw=1.0D20
14189 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14190 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14191 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14192                 return
14193               endif
14194               sigder=-sig*sigsq
14195 !---------------------------------------------------------------
14196               rij_shift=1.0D0/rij_shift
14197               fac=rij_shift**expon
14198               e1=fac*fac*aa
14199               e2=fac*bb
14200               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14201               eps2der=evdwij*eps3rt
14202               eps3der=evdwij*eps2rt
14203 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14204 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14205               evdwij=evdwij*eps2rt*eps3rt
14206               evdw=evdw+evdwij*sss*sss_ele_cut
14207               if (lprn) then
14208               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14209               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14210               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14211                 restyp(itypi,1),i,restyp(itypj,1),j,&
14212                 epsi,sigm,chi1,chi2,chip1,chip2,&
14213                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14214                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14215                 evdwij
14216               endif
14217
14218               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14219                               'evdw',i,j,evdwij
14220 !              if (energy_dec) write (iout,*) &
14221 !                              'evdw',i,j,evdwij,"egb_short"
14222
14223 ! Calculate gradient components.
14224               e1=e1*eps1*eps2rt**2*eps3rt**2
14225               fac=-expon*(e1+evdwij)*rij_shift
14226               sigder=fac*sigder
14227               fac=rij*fac
14228               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14229             *rij+sss_grad/sss*rij  &
14230             /sigmaii(itypi,itypj))
14231
14232 !              fac=0.0d0
14233 ! Calculate the radial part of the gradient
14234               gg(1)=xj*fac
14235               gg(2)=yj*fac
14236               gg(3)=zj*fac
14237 ! Calculate angular part of the gradient.
14238               call sc_grad_scale(sss)
14239             endif
14240           ENDIF !mask_dyn_ss
14241           enddo      ! j
14242         enddo        ! iint
14243       enddo          ! i
14244 !      write (iout,*) "Number of loop steps in EGB:",ind
14245 !ccc      energy_dec=.false.
14246       return
14247       end subroutine egb_short
14248 !-----------------------------------------------------------------------------
14249       subroutine egbv_long(evdw)
14250 !
14251 ! This subroutine calculates the interaction energy of nonbonded side chains
14252 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14253 !
14254       use calc_data
14255 !      implicit real*8 (a-h,o-z)
14256 !      include 'DIMENSIONS'
14257 !      include 'COMMON.GEO'
14258 !      include 'COMMON.VAR'
14259 !      include 'COMMON.LOCAL'
14260 !      include 'COMMON.CHAIN'
14261 !      include 'COMMON.DERIV'
14262 !      include 'COMMON.NAMES'
14263 !      include 'COMMON.INTERACT'
14264 !      include 'COMMON.IOUNITS'
14265 !      include 'COMMON.CALC'
14266       use comm_srutu
14267 !el      integer :: icall
14268 !el      common /srutu/ icall
14269       logical :: lprn
14270 !el local variables
14271       integer :: iint,itypi,itypi1,itypj
14272       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14273                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14274       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14275       evdw=0.0D0
14276 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14277       evdw=0.0D0
14278       lprn=.false.
14279 !     if (icall.eq.0) lprn=.true.
14280 !el      ind=0
14281       do i=iatsc_s,iatsc_e
14282         itypi=itype(i,1)
14283         if (itypi.eq.ntyp1) cycle
14284         itypi1=itype(i+1,1)
14285         xi=c(1,nres+i)
14286         yi=c(2,nres+i)
14287         zi=c(3,nres+i)
14288         call to_box(xi,yi,zi)
14289         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14290         dxi=dc_norm(1,nres+i)
14291         dyi=dc_norm(2,nres+i)
14292         dzi=dc_norm(3,nres+i)
14293
14294 !        dsci_inv=dsc_inv(itypi)
14295         dsci_inv=vbld_inv(i+nres)
14296 !
14297 ! Calculate SC interaction energy.
14298 !
14299         do iint=1,nint_gr(i)
14300           do j=istart(i,iint),iend(i,iint)
14301 !el            ind=ind+1
14302             itypj=itype(j,1)
14303             if (itypj.eq.ntyp1) cycle
14304 !            dscj_inv=dsc_inv(itypj)
14305             dscj_inv=vbld_inv(j+nres)
14306             sig0ij=sigma(itypi,itypj)
14307             r0ij=r0(itypi,itypj)
14308             chi1=chi(itypi,itypj)
14309             chi2=chi(itypj,itypi)
14310             chi12=chi1*chi2
14311             chip1=chip(itypi)
14312             chip2=chip(itypj)
14313             chip12=chip1*chip2
14314             alf1=alp(itypi)
14315             alf2=alp(itypj)
14316             alf12=0.5D0*(alf1+alf2)
14317             xj=c(1,nres+j)-xi
14318             yj=c(2,nres+j)-yi
14319             zj=c(3,nres+j)-zi
14320             call to_box(xj,yj,zj)
14321             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14322             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14323             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14324             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14325             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14326             xj=boxshift(xj-xi,boxxsize)
14327             yj=boxshift(yj-yi,boxysize)
14328             zj=boxshift(zj-zi,boxzsize)
14329             dxj=dc_norm(1,nres+j)
14330             dyj=dc_norm(2,nres+j)
14331             dzj=dc_norm(3,nres+j)
14332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14333             rij=dsqrt(rrij)
14334
14335             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14336
14337             if (sss.lt.1.0d0) then
14338
14339 ! Calculate angle-dependent terms of energy and contributions to their
14340 ! derivatives.
14341               call sc_angular
14342               sigsq=1.0D0/sigsq
14343               sig=sig0ij*dsqrt(sigsq)
14344               rij_shift=1.0D0/rij-sig+r0ij
14345 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14346               if (rij_shift.le.0.0D0) then
14347                 evdw=1.0D20
14348                 return
14349               endif
14350               sigder=-sig*sigsq
14351 !---------------------------------------------------------------
14352               rij_shift=1.0D0/rij_shift
14353               fac=rij_shift**expon
14354               e1=fac*fac*aa_aq(itypi,itypj)
14355               e2=fac*bb_aq(itypi,itypj)
14356               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14357               eps2der=evdwij*eps3rt
14358               eps3der=evdwij*eps2rt
14359               fac_augm=rrij**expon
14360               e_augm=augm(itypi,itypj)*fac_augm
14361               evdwij=evdwij*eps2rt*eps3rt
14362               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14363               if (lprn) then
14364               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14365               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14366               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14367                 restyp(itypi,1),i,restyp(itypj,1),j,&
14368                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14369                 chi1,chi2,chip1,chip2,&
14370                 eps1,eps2rt**2,eps3rt**2,&
14371                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14372                 evdwij+e_augm
14373               endif
14374 ! Calculate gradient components.
14375               e1=e1*eps1*eps2rt**2*eps3rt**2
14376               fac=-expon*(e1+evdwij)*rij_shift
14377               sigder=fac*sigder
14378               fac=rij*fac-2*expon*rrij*e_augm
14379 ! Calculate the radial part of the gradient
14380               gg(1)=xj*fac
14381               gg(2)=yj*fac
14382               gg(3)=zj*fac
14383 ! Calculate angular part of the gradient.
14384               call sc_grad_scale(1.0d0-sss)
14385             endif
14386           enddo      ! j
14387         enddo        ! iint
14388       enddo          ! i
14389       end subroutine egbv_long
14390 !-----------------------------------------------------------------------------
14391       subroutine egbv_short(evdw)
14392 !
14393 ! This subroutine calculates the interaction energy of nonbonded side chains
14394 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14395 !
14396       use calc_data
14397 !      implicit real*8 (a-h,o-z)
14398 !      include 'DIMENSIONS'
14399 !      include 'COMMON.GEO'
14400 !      include 'COMMON.VAR'
14401 !      include 'COMMON.LOCAL'
14402 !      include 'COMMON.CHAIN'
14403 !      include 'COMMON.DERIV'
14404 !      include 'COMMON.NAMES'
14405 !      include 'COMMON.INTERACT'
14406 !      include 'COMMON.IOUNITS'
14407 !      include 'COMMON.CALC'
14408       use comm_srutu
14409 !el      integer :: icall
14410 !el      common /srutu/ icall
14411       logical :: lprn
14412 !el local variables
14413       integer :: iint,itypi,itypi1,itypj
14414       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
14415                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
14416       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14417       evdw=0.0D0
14418 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14419       evdw=0.0D0
14420       lprn=.false.
14421 !     if (icall.eq.0) lprn=.true.
14422 !el      ind=0
14423       do i=iatsc_s,iatsc_e
14424         itypi=itype(i,1)
14425         if (itypi.eq.ntyp1) cycle
14426         itypi1=itype(i+1,1)
14427         xi=c(1,nres+i)
14428         yi=c(2,nres+i)
14429         zi=c(3,nres+i)
14430         dxi=dc_norm(1,nres+i)
14431         dyi=dc_norm(2,nres+i)
14432         dzi=dc_norm(3,nres+i)
14433         call to_box(xi,yi,zi)
14434         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14435 !        dsci_inv=dsc_inv(itypi)
14436         dsci_inv=vbld_inv(i+nres)
14437 !
14438 ! Calculate SC interaction energy.
14439 !
14440         do iint=1,nint_gr(i)
14441           do j=istart(i,iint),iend(i,iint)
14442 !el            ind=ind+1
14443             itypj=itype(j,1)
14444             if (itypj.eq.ntyp1) cycle
14445 !            dscj_inv=dsc_inv(itypj)
14446             dscj_inv=vbld_inv(j+nres)
14447             sig0ij=sigma(itypi,itypj)
14448             r0ij=r0(itypi,itypj)
14449             chi1=chi(itypi,itypj)
14450             chi2=chi(itypj,itypi)
14451             chi12=chi1*chi2
14452             chip1=chip(itypi)
14453             chip2=chip(itypj)
14454             chip12=chip1*chip2
14455             alf1=alp(itypi)
14456             alf2=alp(itypj)
14457             alf12=0.5D0*(alf1+alf2)
14458             xj=c(1,nres+j)-xi
14459             yj=c(2,nres+j)-yi
14460             zj=c(3,nres+j)-zi
14461             call to_box(xj,yj,zj)
14462             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14463             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14464             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14465             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14466             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14467             xj=boxshift(xj-xi,boxxsize)
14468             yj=boxshift(yj-yi,boxysize)
14469             zj=boxshift(zj-zi,boxzsize)
14470             dxj=dc_norm(1,nres+j)
14471             dyj=dc_norm(2,nres+j)
14472             dzj=dc_norm(3,nres+j)
14473             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14474             rij=dsqrt(rrij)
14475
14476             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14477
14478             if (sss.gt.0.0d0) then
14479
14480 ! Calculate angle-dependent terms of energy and contributions to their
14481 ! derivatives.
14482               call sc_angular
14483               sigsq=1.0D0/sigsq
14484               sig=sig0ij*dsqrt(sigsq)
14485               rij_shift=1.0D0/rij-sig+r0ij
14486 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14487               if (rij_shift.le.0.0D0) then
14488                 evdw=1.0D20
14489                 return
14490               endif
14491               sigder=-sig*sigsq
14492 !---------------------------------------------------------------
14493               rij_shift=1.0D0/rij_shift
14494               fac=rij_shift**expon
14495               e1=fac*fac*aa_aq(itypi,itypj)
14496               e2=fac*bb_aq(itypi,itypj)
14497               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14498               eps2der=evdwij*eps3rt
14499               eps3der=evdwij*eps2rt
14500               fac_augm=rrij**expon
14501               e_augm=augm(itypi,itypj)*fac_augm
14502               evdwij=evdwij*eps2rt*eps3rt
14503               evdw=evdw+(evdwij+e_augm)*sss
14504               if (lprn) then
14505               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14506               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14507               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14508                 restyp(itypi,1),i,restyp(itypj,1),j,&
14509                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14510                 chi1,chi2,chip1,chip2,&
14511                 eps1,eps2rt**2,eps3rt**2,&
14512                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14513                 evdwij+e_augm
14514               endif
14515 ! Calculate gradient components.
14516               e1=e1*eps1*eps2rt**2*eps3rt**2
14517               fac=-expon*(e1+evdwij)*rij_shift
14518               sigder=fac*sigder
14519               fac=rij*fac-2*expon*rrij*e_augm
14520 ! Calculate the radial part of the gradient
14521               gg(1)=xj*fac
14522               gg(2)=yj*fac
14523               gg(3)=zj*fac
14524 ! Calculate angular part of the gradient.
14525               call sc_grad_scale(sss)
14526             endif
14527           enddo      ! j
14528         enddo        ! iint
14529       enddo          ! i
14530       end subroutine egbv_short
14531 !-----------------------------------------------------------------------------
14532       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14533 !
14534 ! This subroutine calculates the average interaction energy and its gradient
14535 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14536 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14537 ! The potential depends both on the distance of peptide-group centers and on
14538 ! the orientation of the CA-CA virtual bonds.
14539 !
14540 !      implicit real*8 (a-h,o-z)
14541
14542       use comm_locel
14543 #ifdef MPI
14544       include 'mpif.h'
14545 #endif
14546 !      include 'DIMENSIONS'
14547 !      include 'COMMON.CONTROL'
14548 !      include 'COMMON.SETUP'
14549 !      include 'COMMON.IOUNITS'
14550 !      include 'COMMON.GEO'
14551 !      include 'COMMON.VAR'
14552 !      include 'COMMON.LOCAL'
14553 !      include 'COMMON.CHAIN'
14554 !      include 'COMMON.DERIV'
14555 !      include 'COMMON.INTERACT'
14556 !      include 'COMMON.CONTACTS'
14557 !      include 'COMMON.TORSION'
14558 !      include 'COMMON.VECTORS'
14559 !      include 'COMMON.FFIELD'
14560 !      include 'COMMON.TIME1'
14561       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14562       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14563       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14564 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14565       real(kind=8),dimension(4) :: muij
14566 !el      integer :: num_conti,j1,j2
14567 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14568 !el                   dz_normi,xmedi,ymedi,zmedi
14569 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14570 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14571 !el          num_conti,j1,j2
14572 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14573 #ifdef MOMENT
14574       real(kind=8) :: scal_el=1.0d0
14575 #else
14576       real(kind=8) :: scal_el=0.5d0
14577 #endif
14578 ! 12/13/98
14579 ! 13-go grudnia roku pamietnego...
14580       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14581                                              0.0d0,1.0d0,0.0d0,&
14582                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14583 !el local variables
14584       integer :: i,j,k
14585       real(kind=8) :: fac
14586       real(kind=8) :: dxj,dyj,dzj
14587       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14588
14589 !      allocate(num_cont_hb(nres)) !(maxres)
14590 !d      write(iout,*) 'In EELEC'
14591 !d      do i=1,nloctyp
14592 !d        write(iout,*) 'Type',i
14593 !d        write(iout,*) 'B1',B1(:,i)
14594 !d        write(iout,*) 'B2',B2(:,i)
14595 !d        write(iout,*) 'CC',CC(:,:,i)
14596 !d        write(iout,*) 'DD',DD(:,:,i)
14597 !d        write(iout,*) 'EE',EE(:,:,i)
14598 !d      enddo
14599 !d      call check_vecgrad
14600 !d      stop
14601       if (icheckgrad.eq.1) then
14602         do i=1,nres-1
14603           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14604           do k=1,3
14605             dc_norm(k,i)=dc(k,i)*fac
14606           enddo
14607 !          write (iout,*) 'i',i,' fac',fac
14608         enddo
14609       endif
14610       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14611           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14612           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14613 !        call vec_and_deriv
14614 #ifdef TIMING
14615         time01=MPI_Wtime()
14616 #endif
14617 !        print *, "before set matrices"
14618         call set_matrices
14619 !        print *,"after set martices"
14620 #ifdef TIMING
14621         time_mat=time_mat+MPI_Wtime()-time01
14622 #endif
14623       endif
14624 !d      do i=1,nres-1
14625 !d        write (iout,*) 'i=',i
14626 !d        do k=1,3
14627 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14628 !d        enddo
14629 !d        do k=1,3
14630 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14631 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14632 !d        enddo
14633 !d      enddo
14634       t_eelecij=0.0d0
14635       ees=0.0D0
14636       evdw1=0.0D0
14637       eel_loc=0.0d0
14638       eello_turn3=0.0d0
14639       eello_turn4=0.0d0
14640 !el      ind=0
14641       do i=1,nres
14642         num_cont_hb(i)=0
14643       enddo
14644 !d      print '(a)','Enter EELEC'
14645 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14646 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14647 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14648       do i=1,nres
14649         gel_loc_loc(i)=0.0d0
14650         gcorr_loc(i)=0.0d0
14651       enddo
14652 !
14653 !
14654 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14655 !
14656 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14657 !
14658       do i=iturn3_start,iturn3_end
14659         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14660         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14661         dxi=dc(1,i)
14662         dyi=dc(2,i)
14663         dzi=dc(3,i)
14664         dx_normi=dc_norm(1,i)
14665         dy_normi=dc_norm(2,i)
14666         dz_normi=dc_norm(3,i)
14667         xmedi=c(1,i)+0.5d0*dxi
14668         ymedi=c(2,i)+0.5d0*dyi
14669         zmedi=c(3,i)+0.5d0*dzi
14670         call to_box(xmedi,ymedi,zmedi)
14671         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14672         num_conti=0
14673         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14674         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14675         num_cont_hb(i)=num_conti
14676       enddo
14677       do i=iturn4_start,iturn4_end
14678         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14679           .or. itype(i+3,1).eq.ntyp1 &
14680           .or. itype(i+4,1).eq.ntyp1) cycle
14681         dxi=dc(1,i)
14682         dyi=dc(2,i)
14683         dzi=dc(3,i)
14684         dx_normi=dc_norm(1,i)
14685         dy_normi=dc_norm(2,i)
14686         dz_normi=dc_norm(3,i)
14687         xmedi=c(1,i)+0.5d0*dxi
14688         ymedi=c(2,i)+0.5d0*dyi
14689         zmedi=c(3,i)+0.5d0*dzi
14690
14691         call to_box(xmedi,ymedi,zmedi)
14692         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14693
14694         num_conti=num_cont_hb(i)
14695         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14696         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14697           call eturn4(i,eello_turn4)
14698         num_cont_hb(i)=num_conti
14699       enddo   ! i
14700 !
14701 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14702 !
14703       do i=iatel_s,iatel_e
14704         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14705         dxi=dc(1,i)
14706         dyi=dc(2,i)
14707         dzi=dc(3,i)
14708         dx_normi=dc_norm(1,i)
14709         dy_normi=dc_norm(2,i)
14710         dz_normi=dc_norm(3,i)
14711         xmedi=c(1,i)+0.5d0*dxi
14712         ymedi=c(2,i)+0.5d0*dyi
14713         zmedi=c(3,i)+0.5d0*dzi
14714         call to_box(xmedi,ymedi,zmedi)
14715         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14716 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14717         num_conti=num_cont_hb(i)
14718         do j=ielstart(i),ielend(i)
14719           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14720           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14721         enddo ! j
14722         num_cont_hb(i)=num_conti
14723       enddo   ! i
14724 !      write (iout,*) "Number of loop steps in EELEC:",ind
14725 !d      do i=1,nres
14726 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14727 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14728 !d      enddo
14729 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14730 !cc      eel_loc=eel_loc+eello_turn3
14731 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14732       return
14733       end subroutine eelec_scale
14734 !-----------------------------------------------------------------------------
14735       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14736 !      implicit real*8 (a-h,o-z)
14737
14738       use comm_locel
14739 !      include 'DIMENSIONS'
14740 #ifdef MPI
14741       include "mpif.h"
14742 #endif
14743 !      include 'COMMON.CONTROL'
14744 !      include 'COMMON.IOUNITS'
14745 !      include 'COMMON.GEO'
14746 !      include 'COMMON.VAR'
14747 !      include 'COMMON.LOCAL'
14748 !      include 'COMMON.CHAIN'
14749 !      include 'COMMON.DERIV'
14750 !      include 'COMMON.INTERACT'
14751 !      include 'COMMON.CONTACTS'
14752 !      include 'COMMON.TORSION'
14753 !      include 'COMMON.VECTORS'
14754 !      include 'COMMON.FFIELD'
14755 !      include 'COMMON.TIME1'
14756       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14757       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14758       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14759 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14760       real(kind=8),dimension(4) :: muij
14761       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14762                     dist_temp, dist_init,sss_grad
14763       integer xshift,yshift,zshift
14764
14765 !el      integer :: num_conti,j1,j2
14766 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14767 !el                   dz_normi,xmedi,ymedi,zmedi
14768 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14769 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14770 !el          num_conti,j1,j2
14771 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14772 #ifdef MOMENT
14773       real(kind=8) :: scal_el=1.0d0
14774 #else
14775       real(kind=8) :: scal_el=0.5d0
14776 #endif
14777 ! 12/13/98
14778 ! 13-go grudnia roku pamietnego...
14779       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14780                                              0.0d0,1.0d0,0.0d0,&
14781                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14782 !el local variables
14783       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14784       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14785       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14786       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14787       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14788       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14789       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14790                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14791                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14792                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14793                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14794                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
14795 !      integer :: maxconts
14796 !      maxconts = nres/4
14797 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14798 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14799 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14800 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14801 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14802 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14803 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14804 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14805 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14806 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14807 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14808 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14809 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14810
14811 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14812 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14813
14814 #ifdef MPI
14815           time00=MPI_Wtime()
14816 #endif
14817 !d      write (iout,*) "eelecij",i,j
14818 !el          ind=ind+1
14819           iteli=itel(i)
14820           itelj=itel(j)
14821           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14822           aaa=app(iteli,itelj)
14823           bbb=bpp(iteli,itelj)
14824           ael6i=ael6(iteli,itelj)
14825           ael3i=ael3(iteli,itelj)
14826           dxj=dc(1,j)
14827           dyj=dc(2,j)
14828           dzj=dc(3,j)
14829           dx_normj=dc_norm(1,j)
14830           dy_normj=dc_norm(2,j)
14831           dz_normj=dc_norm(3,j)
14832 !          xj=c(1,j)+0.5D0*dxj-xmedi
14833 !          yj=c(2,j)+0.5D0*dyj-ymedi
14834 !          zj=c(3,j)+0.5D0*dzj-zmedi
14835           xj=c(1,j)+0.5D0*dxj
14836           yj=c(2,j)+0.5D0*dyj
14837           zj=c(3,j)+0.5D0*dzj
14838           call to_box(xj,yj,zj)
14839           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14840           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
14841           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
14842           xj=boxshift(xj-xmedi,boxxsize)
14843           yj=boxshift(yj-ymedi,boxysize)
14844           zj=boxshift(zj-zmedi,boxzsize)
14845           rij=xj*xj+yj*yj+zj*zj
14846           rrmij=1.0D0/rij
14847           rij=dsqrt(rij)
14848           rmij=1.0D0/rij
14849 ! For extracting the short-range part of Evdwpp
14850           sss=sscale(rij/rpp(iteli,itelj))
14851             sss_ele_cut=sscale_ele(rij)
14852             sss_ele_grad=sscagrad_ele(rij)
14853             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14854 !             sss_ele_cut=1.0d0
14855 !             sss_ele_grad=0.0d0
14856             if (sss_ele_cut.le.0.0) go to 128
14857
14858           r3ij=rrmij*rmij
14859           r6ij=r3ij*r3ij
14860           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14861           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14862           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14863           fac=cosa-3.0D0*cosb*cosg
14864           ev1=aaa*r6ij*r6ij
14865 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14866           if (j.eq.i+2) ev1=scal_el*ev1
14867           ev2=bbb*r6ij
14868           fac3=ael6i*r6ij
14869           fac4=ael3i*r3ij
14870           evdwij=ev1+ev2
14871           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14872           el2=fac4*fac
14873           eesij=el1+el2
14874 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14875           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14876           ees=ees+eesij*sss_ele_cut
14877           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14878 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14879 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14880 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14881 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14882
14883           if (energy_dec) then
14884               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14885               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14886           endif
14887
14888 !
14889 ! Calculate contributions to the Cartesian gradient.
14890 !
14891 #ifdef SPLITELE
14892           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14893           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14894           fac1=fac
14895           erij(1)=xj*rmij
14896           erij(2)=yj*rmij
14897           erij(3)=zj*rmij
14898 !
14899 ! Radial derivatives. First process both termini of the fragment (i,j)
14900 !
14901           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14902           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14903           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14904 !          do k=1,3
14905 !            ghalf=0.5D0*ggg(k)
14906 !            gelc(k,i)=gelc(k,i)+ghalf
14907 !            gelc(k,j)=gelc(k,j)+ghalf
14908 !          enddo
14909 ! 9/28/08 AL Gradient compotents will be summed only at the end
14910           do k=1,3
14911             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14912             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14913           enddo
14914 !
14915 ! Loop over residues i+1 thru j-1.
14916 !
14917 !grad          do k=i+1,j-1
14918 !grad            do l=1,3
14919 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14920 !grad            enddo
14921 !grad          enddo
14922           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14923           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14924           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14925           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14926           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14927           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14928 !          do k=1,3
14929 !            ghalf=0.5D0*ggg(k)
14930 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14931 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14932 !          enddo
14933 ! 9/28/08 AL Gradient compotents will be summed only at the end
14934           do k=1,3
14935             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14936             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14937           enddo
14938 !
14939 ! Loop over residues i+1 thru j-1.
14940 !
14941 !grad          do k=i+1,j-1
14942 !grad            do l=1,3
14943 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14944 !grad            enddo
14945 !grad          enddo
14946 #else
14947           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14948           facel=(el1+eesij)*sss_ele_cut
14949           fac1=fac
14950           fac=-3*rrmij*(facvdw+facvdw+facel)
14951           erij(1)=xj*rmij
14952           erij(2)=yj*rmij
14953           erij(3)=zj*rmij
14954 !
14955 ! Radial derivatives. First process both termini of the fragment (i,j)
14956 !
14957           ggg(1)=fac*xj
14958           ggg(2)=fac*yj
14959           ggg(3)=fac*zj
14960 !          do k=1,3
14961 !            ghalf=0.5D0*ggg(k)
14962 !            gelc(k,i)=gelc(k,i)+ghalf
14963 !            gelc(k,j)=gelc(k,j)+ghalf
14964 !          enddo
14965 ! 9/28/08 AL Gradient compotents will be summed only at the end
14966           do k=1,3
14967             gelc_long(k,j)=gelc(k,j)+ggg(k)
14968             gelc_long(k,i)=gelc(k,i)-ggg(k)
14969           enddo
14970 !
14971 ! Loop over residues i+1 thru j-1.
14972 !
14973 !grad          do k=i+1,j-1
14974 !grad            do l=1,3
14975 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14976 !grad            enddo
14977 !grad          enddo
14978 ! 9/28/08 AL Gradient compotents will be summed only at the end
14979           ggg(1)=facvdw*xj
14980           ggg(2)=facvdw*yj
14981           ggg(3)=facvdw*zj
14982           do k=1,3
14983             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14984             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14985           enddo
14986 #endif
14987 !
14988 ! Angular part
14989 !
14990           ecosa=2.0D0*fac3*fac1+fac4
14991           fac4=-3.0D0*fac4
14992           fac3=-6.0D0*fac3
14993           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14994           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14995           do k=1,3
14996             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14997             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14998           enddo
14999 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15000 !d   &          (dcosg(k),k=1,3)
15001           do k=1,3
15002             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15003           enddo
15004 !          do k=1,3
15005 !            ghalf=0.5D0*ggg(k)
15006 !            gelc(k,i)=gelc(k,i)+ghalf
15007 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15008 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15009 !            gelc(k,j)=gelc(k,j)+ghalf
15010 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15011 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15012 !          enddo
15013 !grad          do k=i+1,j-1
15014 !grad            do l=1,3
15015 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15016 !grad            enddo
15017 !grad          enddo
15018           do k=1,3
15019             gelc(k,i)=gelc(k,i) &
15020                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15021                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15022                      *sss_ele_cut
15023             gelc(k,j)=gelc(k,j) &
15024                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15025                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15026                      *sss_ele_cut
15027             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15028             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15029           enddo
15030           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15031               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15032               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15033 !
15034 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15035 !   energy of a peptide unit is assumed in the form of a second-order
15036 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15037 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15038 !   are computed for EVERY pair of non-contiguous peptide groups.
15039 !
15040           if (j.lt.nres-1) then
15041             j1=j+1
15042             j2=j-1
15043           else
15044             j1=j-1
15045             j2=j-2
15046           endif
15047           kkk=0
15048           do k=1,2
15049             do l=1,2
15050               kkk=kkk+1
15051               muij(kkk)=mu(k,i)*mu(l,j)
15052             enddo
15053           enddo
15054 !d         write (iout,*) 'EELEC: i',i,' j',j
15055 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15056 !d          write(iout,*) 'muij',muij
15057           ury=scalar(uy(1,i),erij)
15058           urz=scalar(uz(1,i),erij)
15059           vry=scalar(uy(1,j),erij)
15060           vrz=scalar(uz(1,j),erij)
15061           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15062           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15063           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15064           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15065           fac=dsqrt(-ael6i)*r3ij
15066           a22=a22*fac
15067           a23=a23*fac
15068           a32=a32*fac
15069           a33=a33*fac
15070 !d          write (iout,'(4i5,4f10.5)')
15071 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15072 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15073 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15074 !d     &      uy(:,j),uz(:,j)
15075 !d          write (iout,'(4f10.5)')
15076 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15077 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15078 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15079 !d           write (iout,'(9f10.5/)')
15080 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15081 ! Derivatives of the elements of A in virtual-bond vectors
15082           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15083           do k=1,3
15084             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15085             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15086             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15087             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15088             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15089             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15090             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15091             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15092             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15093             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15094             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15095             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15096           enddo
15097 ! Compute radial contributions to the gradient
15098           facr=-3.0d0*rrmij
15099           a22der=a22*facr
15100           a23der=a23*facr
15101           a32der=a32*facr
15102           a33der=a33*facr
15103           agg(1,1)=a22der*xj
15104           agg(2,1)=a22der*yj
15105           agg(3,1)=a22der*zj
15106           agg(1,2)=a23der*xj
15107           agg(2,2)=a23der*yj
15108           agg(3,2)=a23der*zj
15109           agg(1,3)=a32der*xj
15110           agg(2,3)=a32der*yj
15111           agg(3,3)=a32der*zj
15112           agg(1,4)=a33der*xj
15113           agg(2,4)=a33der*yj
15114           agg(3,4)=a33der*zj
15115 ! Add the contributions coming from er
15116           fac3=-3.0d0*fac
15117           do k=1,3
15118             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15119             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15120             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15121             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15122           enddo
15123           do k=1,3
15124 ! Derivatives in DC(i)
15125 !grad            ghalf1=0.5d0*agg(k,1)
15126 !grad            ghalf2=0.5d0*agg(k,2)
15127 !grad            ghalf3=0.5d0*agg(k,3)
15128 !grad            ghalf4=0.5d0*agg(k,4)
15129             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15130             -3.0d0*uryg(k,2)*vry)!+ghalf1
15131             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15132             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15133             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15134             -3.0d0*urzg(k,2)*vry)!+ghalf3
15135             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15136             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15137 ! Derivatives in DC(i+1)
15138             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15139             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15140             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15141             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15142             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15143             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15144             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15145             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15146 ! Derivatives in DC(j)
15147             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15148             -3.0d0*vryg(k,2)*ury)!+ghalf1
15149             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15150             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15151             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15152             -3.0d0*vryg(k,2)*urz)!+ghalf3
15153             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15154             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15155 ! Derivatives in DC(j+1) or DC(nres-1)
15156             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15157             -3.0d0*vryg(k,3)*ury)
15158             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15159             -3.0d0*vrzg(k,3)*ury)
15160             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15161             -3.0d0*vryg(k,3)*urz)
15162             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15163             -3.0d0*vrzg(k,3)*urz)
15164 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15165 !grad              do l=1,4
15166 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15167 !grad              enddo
15168 !grad            endif
15169           enddo
15170           acipa(1,1)=a22
15171           acipa(1,2)=a23
15172           acipa(2,1)=a32
15173           acipa(2,2)=a33
15174           a22=-a22
15175           a23=-a23
15176           do l=1,2
15177             do k=1,3
15178               agg(k,l)=-agg(k,l)
15179               aggi(k,l)=-aggi(k,l)
15180               aggi1(k,l)=-aggi1(k,l)
15181               aggj(k,l)=-aggj(k,l)
15182               aggj1(k,l)=-aggj1(k,l)
15183             enddo
15184           enddo
15185           if (j.lt.nres-1) then
15186             a22=-a22
15187             a32=-a32
15188             do l=1,3,2
15189               do k=1,3
15190                 agg(k,l)=-agg(k,l)
15191                 aggi(k,l)=-aggi(k,l)
15192                 aggi1(k,l)=-aggi1(k,l)
15193                 aggj(k,l)=-aggj(k,l)
15194                 aggj1(k,l)=-aggj1(k,l)
15195               enddo
15196             enddo
15197           else
15198             a22=-a22
15199             a23=-a23
15200             a32=-a32
15201             a33=-a33
15202             do l=1,4
15203               do k=1,3
15204                 agg(k,l)=-agg(k,l)
15205                 aggi(k,l)=-aggi(k,l)
15206                 aggi1(k,l)=-aggi1(k,l)
15207                 aggj(k,l)=-aggj(k,l)
15208                 aggj1(k,l)=-aggj1(k,l)
15209               enddo
15210             enddo
15211           endif
15212           ENDIF ! WCORR
15213           IF (wel_loc.gt.0.0d0) THEN
15214 ! Contribution to the local-electrostatic energy coming from the i-j pair
15215           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15216            +a33*muij(4)
15217 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15218 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15219           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15220                   'eelloc',i,j,eel_loc_ij
15221 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15222
15223           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15224 ! Partial derivatives in virtual-bond dihedral angles gamma
15225           if (i.gt.1) &
15226           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15227                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15228                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15229                  *sss_ele_cut
15230           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15231                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15232                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15233                  *sss_ele_cut
15234            xtemp(1)=xj
15235            xtemp(2)=yj
15236            xtemp(3)=zj
15237
15238 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15239           do l=1,3
15240             ggg(l)=(agg(l,1)*muij(1)+ &
15241                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15242             *sss_ele_cut &
15243              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15244
15245             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15246             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15247 !grad            ghalf=0.5d0*ggg(l)
15248 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15249 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15250           enddo
15251 !grad          do k=i+1,j2
15252 !grad            do l=1,3
15253 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15254 !grad            enddo
15255 !grad          enddo
15256 ! Remaining derivatives of eello
15257           do l=1,3
15258             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15259                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15260             *sss_ele_cut
15261
15262             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15263                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15264             *sss_ele_cut
15265
15266             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15267                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15268             *sss_ele_cut
15269
15270             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15271                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15272             *sss_ele_cut
15273
15274           enddo
15275           ENDIF
15276 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15277 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15278           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15279              .and. num_conti.le.maxconts) then
15280 !            write (iout,*) i,j," entered corr"
15281 !
15282 ! Calculate the contact function. The ith column of the array JCONT will
15283 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15284 ! greater than I). The arrays FACONT and GACONT will contain the values of
15285 ! the contact function and its derivative.
15286 !           r0ij=1.02D0*rpp(iteli,itelj)
15287 !           r0ij=1.11D0*rpp(iteli,itelj)
15288             r0ij=2.20D0*rpp(iteli,itelj)
15289 !           r0ij=1.55D0*rpp(iteli,itelj)
15290             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15291 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15292             if (fcont.gt.0.0D0) then
15293               num_conti=num_conti+1
15294               if (num_conti.gt.maxconts) then
15295 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15296                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15297                                ' will skip next contacts for this conf.',num_conti
15298               else
15299                 jcont_hb(num_conti,i)=j
15300 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15301 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15302                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15303                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15304 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15305 !  terms.
15306                 d_cont(num_conti,i)=rij
15307 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15308 !     --- Electrostatic-interaction matrix ---
15309                 a_chuj(1,1,num_conti,i)=a22
15310                 a_chuj(1,2,num_conti,i)=a23
15311                 a_chuj(2,1,num_conti,i)=a32
15312                 a_chuj(2,2,num_conti,i)=a33
15313 !     --- Gradient of rij
15314                 do kkk=1,3
15315                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15316                 enddo
15317                 kkll=0
15318                 do k=1,2
15319                   do l=1,2
15320                     kkll=kkll+1
15321                     do m=1,3
15322                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15323                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15324                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15325                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15326                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15327                     enddo
15328                   enddo
15329                 enddo
15330                 ENDIF
15331                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15332 ! Calculate contact energies
15333                 cosa4=4.0D0*cosa
15334                 wij=cosa-3.0D0*cosb*cosg
15335                 cosbg1=cosb+cosg
15336                 cosbg2=cosb-cosg
15337 !               fac3=dsqrt(-ael6i)/r0ij**3
15338                 fac3=dsqrt(-ael6i)*r3ij
15339 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15340                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15341                 if (ees0tmp.gt.0) then
15342                   ees0pij=dsqrt(ees0tmp)
15343                 else
15344                   ees0pij=0
15345                 endif
15346 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15347                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15348                 if (ees0tmp.gt.0) then
15349                   ees0mij=dsqrt(ees0tmp)
15350                 else
15351                   ees0mij=0
15352                 endif
15353 !               ees0mij=0.0D0
15354                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15355                      *sss_ele_cut
15356
15357                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15358                      *sss_ele_cut
15359
15360 ! Diagnostics. Comment out or remove after debugging!
15361 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15362 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15363 !               ees0m(num_conti,i)=0.0D0
15364 ! End diagnostics.
15365 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15366 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15367 ! Angular derivatives of the contact function
15368                 ees0pij1=fac3/ees0pij
15369                 ees0mij1=fac3/ees0mij
15370                 fac3p=-3.0D0*fac3*rrmij
15371                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15372                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15373 !               ees0mij1=0.0D0
15374                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15375                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15376                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15377                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15378                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15379                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15380                 ecosap=ecosa1+ecosa2
15381                 ecosbp=ecosb1+ecosb2
15382                 ecosgp=ecosg1+ecosg2
15383                 ecosam=ecosa1-ecosa2
15384                 ecosbm=ecosb1-ecosb2
15385                 ecosgm=ecosg1-ecosg2
15386 ! Diagnostics
15387 !               ecosap=ecosa1
15388 !               ecosbp=ecosb1
15389 !               ecosgp=ecosg1
15390 !               ecosam=0.0D0
15391 !               ecosbm=0.0D0
15392 !               ecosgm=0.0D0
15393 ! End diagnostics
15394                 facont_hb(num_conti,i)=fcont
15395                 fprimcont=fprimcont/rij
15396 !d              facont_hb(num_conti,i)=1.0D0
15397 ! Following line is for diagnostics.
15398 !d              fprimcont=0.0D0
15399                 do k=1,3
15400                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15401                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15402                 enddo
15403                 do k=1,3
15404                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15405                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15406                 enddo
15407 !                gggp(1)=gggp(1)+ees0pijp*xj
15408 !                gggp(2)=gggp(2)+ees0pijp*yj
15409 !                gggp(3)=gggp(3)+ees0pijp*zj
15410 !                gggm(1)=gggm(1)+ees0mijp*xj
15411 !                gggm(2)=gggm(2)+ees0mijp*yj
15412 !                gggm(3)=gggm(3)+ees0mijp*zj
15413                 gggp(1)=gggp(1)+ees0pijp*xj &
15414                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15415                 gggp(2)=gggp(2)+ees0pijp*yj &
15416                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15417                 gggp(3)=gggp(3)+ees0pijp*zj &
15418                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15419
15420                 gggm(1)=gggm(1)+ees0mijp*xj &
15421                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15422
15423                 gggm(2)=gggm(2)+ees0mijp*yj &
15424                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15425
15426                 gggm(3)=gggm(3)+ees0mijp*zj &
15427                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15428
15429 ! Derivatives due to the contact function
15430                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15431                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15432                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15433                 do k=1,3
15434 !
15435 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15436 !          following the change of gradient-summation algorithm.
15437 !
15438 !grad                  ghalfp=0.5D0*gggp(k)
15439 !grad                  ghalfm=0.5D0*gggm(k)
15440 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15441 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15442 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15443 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15444 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15445 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15446 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15447 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15448 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15449 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15450 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15451 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15452 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15453 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15454                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15455                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15456                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15457                      *sss_ele_cut
15458
15459                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15460                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15461                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15462                      *sss_ele_cut
15463
15464                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15465                      *sss_ele_cut
15466
15467                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15468                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15469                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15470                      *sss_ele_cut
15471
15472                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15473                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15474                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15475                      *sss_ele_cut
15476
15477                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15478                      *sss_ele_cut
15479
15480                 enddo
15481               ENDIF ! wcorr
15482               endif  ! num_conti.le.maxconts
15483             endif  ! fcont.gt.0
15484           endif    ! j.gt.i+1
15485           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15486             do k=1,4
15487               do l=1,3
15488                 ghalf=0.5d0*agg(l,k)
15489                 aggi(l,k)=aggi(l,k)+ghalf
15490                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15491                 aggj(l,k)=aggj(l,k)+ghalf
15492               enddo
15493             enddo
15494             if (j.eq.nres-1 .and. i.lt.j-2) then
15495               do k=1,4
15496                 do l=1,3
15497                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15498                 enddo
15499               enddo
15500             endif
15501           endif
15502  128      continue
15503 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15504       return
15505       end subroutine eelecij_scale
15506 !-----------------------------------------------------------------------------
15507       subroutine evdwpp_short(evdw1)
15508 !
15509 ! Compute Evdwpp
15510 !
15511 !      implicit real*8 (a-h,o-z)
15512 !      include 'DIMENSIONS'
15513 !      include 'COMMON.CONTROL'
15514 !      include 'COMMON.IOUNITS'
15515 !      include 'COMMON.GEO'
15516 !      include 'COMMON.VAR'
15517 !      include 'COMMON.LOCAL'
15518 !      include 'COMMON.CHAIN'
15519 !      include 'COMMON.DERIV'
15520 !      include 'COMMON.INTERACT'
15521 !      include 'COMMON.CONTACTS'
15522 !      include 'COMMON.TORSION'
15523 !      include 'COMMON.VECTORS'
15524 !      include 'COMMON.FFIELD'
15525       real(kind=8),dimension(3) :: ggg
15526 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15527 #ifdef MOMENT
15528       real(kind=8) :: scal_el=1.0d0
15529 #else
15530       real(kind=8) :: scal_el=0.5d0
15531 #endif
15532 !el local variables
15533       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15534       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15535       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15536                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15537                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15538       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15539                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
15540                    sslipj,ssgradlipj,faclipij2
15541       integer xshift,yshift,zshift
15542
15543
15544       evdw1=0.0D0
15545 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15546 !     & " iatel_e_vdw",iatel_e_vdw
15547       call flush(iout)
15548       do i=iatel_s_vdw,iatel_e_vdw
15549         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15550         dxi=dc(1,i)
15551         dyi=dc(2,i)
15552         dzi=dc(3,i)
15553         dx_normi=dc_norm(1,i)
15554         dy_normi=dc_norm(2,i)
15555         dz_normi=dc_norm(3,i)
15556         xmedi=c(1,i)+0.5d0*dxi
15557         ymedi=c(2,i)+0.5d0*dyi
15558         zmedi=c(3,i)+0.5d0*dzi
15559         call to_box(xmedi,ymedi,zmedi)
15560         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15561         num_conti=0
15562 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15563 !     &   ' ielend',ielend_vdw(i)
15564         call flush(iout)
15565         do j=ielstart_vdw(i),ielend_vdw(i)
15566           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15567 !el          ind=ind+1
15568           iteli=itel(i)
15569           itelj=itel(j)
15570           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15571           aaa=app(iteli,itelj)
15572           bbb=bpp(iteli,itelj)
15573           dxj=dc(1,j)
15574           dyj=dc(2,j)
15575           dzj=dc(3,j)
15576           dx_normj=dc_norm(1,j)
15577           dy_normj=dc_norm(2,j)
15578           dz_normj=dc_norm(3,j)
15579 !          xj=c(1,j)+0.5D0*dxj-xmedi
15580 !          yj=c(2,j)+0.5D0*dyj-ymedi
15581 !          zj=c(3,j)+0.5D0*dzj-zmedi
15582           xj=c(1,j)+0.5D0*dxj
15583           yj=c(2,j)+0.5D0*dyj
15584           zj=c(3,j)+0.5D0*dzj
15585           call to_box(xj,yj,zj)
15586           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15587           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15588           xj=boxshift(xj-xmedi,boxxsize)
15589           yj=boxshift(yj-ymedi,boxysize)
15590           zj=boxshift(zj-zmedi,boxzsize)
15591           rij=xj*xj+yj*yj+zj*zj
15592           rrmij=1.0D0/rij
15593           rij=dsqrt(rij)
15594           sss=sscale(rij/rpp(iteli,itelj))
15595             sss_ele_cut=sscale_ele(rij)
15596             sss_ele_grad=sscagrad_ele(rij)
15597             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15598             if (sss_ele_cut.le.0.0) cycle
15599           if (sss.gt.0.0d0) then
15600             rmij=1.0D0/rij
15601             r3ij=rrmij*rmij
15602             r6ij=r3ij*r3ij
15603             ev1=aaa*r6ij*r6ij
15604 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15605             if (j.eq.i+2) ev1=scal_el*ev1
15606             ev2=bbb*r6ij
15607             evdwij=ev1+ev2
15608             if (energy_dec) then
15609               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15610             endif
15611             evdw1=evdw1+evdwij*sss*sss_ele_cut
15612 !
15613 ! Calculate contributions to the Cartesian gradient.
15614 !
15615             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15616 !            ggg(1)=facvdw*xj
15617 !            ggg(2)=facvdw*yj
15618 !            ggg(3)=facvdw*zj
15619           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15620           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15621           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15622           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15623           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15624           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15625
15626             do k=1,3
15627               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15628               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15629             enddo
15630           endif
15631         enddo ! j
15632       enddo   ! i
15633       return
15634       end subroutine evdwpp_short
15635 !-----------------------------------------------------------------------------
15636       subroutine escp_long(evdw2,evdw2_14)
15637 !
15638 ! This subroutine calculates the excluded-volume interaction energy between
15639 ! peptide-group centers and side chains and its gradient in virtual-bond and
15640 ! side-chain vectors.
15641 !
15642 !      implicit real*8 (a-h,o-z)
15643 !      include 'DIMENSIONS'
15644 !      include 'COMMON.GEO'
15645 !      include 'COMMON.VAR'
15646 !      include 'COMMON.LOCAL'
15647 !      include 'COMMON.CHAIN'
15648 !      include 'COMMON.DERIV'
15649 !      include 'COMMON.INTERACT'
15650 !      include 'COMMON.FFIELD'
15651 !      include 'COMMON.IOUNITS'
15652 !      include 'COMMON.CONTROL'
15653       real(kind=8),dimension(3) :: ggg
15654 !el local variables
15655       integer :: i,iint,j,k,iteli,itypj,subchap
15656       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15657       real(kind=8) :: evdw2,evdw2_14,evdwij
15658       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15659                     dist_temp, dist_init
15660
15661       evdw2=0.0D0
15662       evdw2_14=0.0d0
15663 !d    print '(a)','Enter ESCP'
15664 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15665       do i=iatscp_s,iatscp_e
15666         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15667         iteli=itel(i)
15668         xi=0.5D0*(c(1,i)+c(1,i+1))
15669         yi=0.5D0*(c(2,i)+c(2,i+1))
15670         zi=0.5D0*(c(3,i)+c(3,i+1))
15671         call to_box(xi,yi,zi)
15672         do iint=1,nscp_gr(i)
15673
15674         do j=iscpstart(i,iint),iscpend(i,iint)
15675           itypj=itype(j,1)
15676           if (itypj.eq.ntyp1) cycle
15677 ! Uncomment following three lines for SC-p interactions
15678 !         xj=c(1,nres+j)-xi
15679 !         yj=c(2,nres+j)-yi
15680 !         zj=c(3,nres+j)-zi
15681 ! Uncomment following three lines for Ca-p interactions
15682           xj=c(1,j)
15683           yj=c(2,j)
15684           zj=c(3,j)
15685           call to_box(xj,yj,zj)
15686           xj=boxshift(xj-xi,boxxsize)
15687           yj=boxshift(yj-yi,boxysize)
15688           zj=boxshift(zj-zi,boxzsize)
15689           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15690
15691           rij=dsqrt(1.0d0/rrij)
15692             sss_ele_cut=sscale_ele(rij)
15693             sss_ele_grad=sscagrad_ele(rij)
15694 !            print *,sss_ele_cut,sss_ele_grad,&
15695 !            (rij),r_cut_ele,rlamb_ele
15696             if (sss_ele_cut.le.0.0) cycle
15697           sss=sscale((rij/rscp(itypj,iteli)))
15698           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15699           if (sss.lt.1.0d0) then
15700
15701             fac=rrij**expon2
15702             e1=fac*fac*aad(itypj,iteli)
15703             e2=fac*bad(itypj,iteli)
15704             if (iabs(j-i) .le. 2) then
15705               e1=scal14*e1
15706               e2=scal14*e2
15707               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15708             endif
15709             evdwij=e1+e2
15710             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15711             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15712                 'evdw2',i,j,sss,evdwij
15713 !
15714 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15715 !
15716             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15717             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15718             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15719             ggg(1)=xj*fac
15720             ggg(2)=yj*fac
15721             ggg(3)=zj*fac
15722 ! Uncomment following three lines for SC-p interactions
15723 !           do k=1,3
15724 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15725 !           enddo
15726 ! Uncomment following line for SC-p interactions
15727 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15728             do k=1,3
15729               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15730               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15731             enddo
15732           endif
15733         enddo
15734
15735         enddo ! iint
15736       enddo ! i
15737       do i=1,nct
15738         do j=1,3
15739           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15740           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15741           gradx_scp(j,i)=expon*gradx_scp(j,i)
15742         enddo
15743       enddo
15744 !******************************************************************************
15745 !
15746 !                              N O T E !!!
15747 !
15748 ! To save time the factor EXPON has been extracted from ALL components
15749 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15750 ! use!
15751 !
15752 !******************************************************************************
15753       return
15754       end subroutine escp_long
15755 !-----------------------------------------------------------------------------
15756       subroutine escp_short(evdw2,evdw2_14)
15757 !
15758 ! This subroutine calculates the excluded-volume interaction energy between
15759 ! peptide-group centers and side chains and its gradient in virtual-bond and
15760 ! side-chain vectors.
15761 !
15762 !      implicit real*8 (a-h,o-z)
15763 !      include 'DIMENSIONS'
15764 !      include 'COMMON.GEO'
15765 !      include 'COMMON.VAR'
15766 !      include 'COMMON.LOCAL'
15767 !      include 'COMMON.CHAIN'
15768 !      include 'COMMON.DERIV'
15769 !      include 'COMMON.INTERACT'
15770 !      include 'COMMON.FFIELD'
15771 !      include 'COMMON.IOUNITS'
15772 !      include 'COMMON.CONTROL'
15773       real(kind=8),dimension(3) :: ggg
15774 !el local variables
15775       integer :: i,iint,j,k,iteli,itypj,subchap
15776       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15777       real(kind=8) :: evdw2,evdw2_14,evdwij
15778       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15779                     dist_temp, dist_init
15780
15781       evdw2=0.0D0
15782       evdw2_14=0.0d0
15783 !d    print '(a)','Enter ESCP'
15784 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15785       do i=iatscp_s,iatscp_e
15786         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15787         iteli=itel(i)
15788         xi=0.5D0*(c(1,i)+c(1,i+1))
15789         yi=0.5D0*(c(2,i)+c(2,i+1))
15790         zi=0.5D0*(c(3,i)+c(3,i+1))
15791         call to_box(xi,yi,zi)
15792         if (zi.lt.0) zi=zi+boxzsize
15793
15794         do iint=1,nscp_gr(i)
15795
15796         do j=iscpstart(i,iint),iscpend(i,iint)
15797           itypj=itype(j,1)
15798           if (itypj.eq.ntyp1) cycle
15799 ! Uncomment following three lines for SC-p interactions
15800 !         xj=c(1,nres+j)-xi
15801 !         yj=c(2,nres+j)-yi
15802 !         zj=c(3,nres+j)-zi
15803 ! Uncomment following three lines for Ca-p interactions
15804 !          xj=c(1,j)-xi
15805 !          yj=c(2,j)-yi
15806 !          zj=c(3,j)-zi
15807           xj=c(1,j)
15808           yj=c(2,j)
15809           zj=c(3,j)
15810           call to_box(xj,yj,zj)
15811           xj=boxshift(xj-xi,boxxsize)
15812           yj=boxshift(yj-yi,boxysize)
15813           zj=boxshift(zj-zi,boxzsize)
15814           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15815           rij=dsqrt(1.0d0/rrij)
15816             sss_ele_cut=sscale_ele(rij)
15817             sss_ele_grad=sscagrad_ele(rij)
15818 !            print *,sss_ele_cut,sss_ele_grad,&
15819 !            (rij),r_cut_ele,rlamb_ele
15820             if (sss_ele_cut.le.0.0) cycle
15821           sss=sscale(rij/rscp(itypj,iteli))
15822           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15823           if (sss.gt.0.0d0) then
15824
15825             fac=rrij**expon2
15826             e1=fac*fac*aad(itypj,iteli)
15827             e2=fac*bad(itypj,iteli)
15828             if (iabs(j-i) .le. 2) then
15829               e1=scal14*e1
15830               e2=scal14*e2
15831               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15832             endif
15833             evdwij=e1+e2
15834             evdw2=evdw2+evdwij*sss*sss_ele_cut
15835             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15836                 'evdw2',i,j,sss,evdwij
15837 !
15838 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15839 !
15840             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15841             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15842             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15843
15844             ggg(1)=xj*fac
15845             ggg(2)=yj*fac
15846             ggg(3)=zj*fac
15847 ! Uncomment following three lines for SC-p interactions
15848 !           do k=1,3
15849 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15850 !           enddo
15851 ! Uncomment following line for SC-p interactions
15852 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15853             do k=1,3
15854               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15855               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15856             enddo
15857           endif
15858         enddo
15859
15860         enddo ! iint
15861       enddo ! i
15862       do i=1,nct
15863         do j=1,3
15864           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15865           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15866           gradx_scp(j,i)=expon*gradx_scp(j,i)
15867         enddo
15868       enddo
15869 !******************************************************************************
15870 !
15871 !                              N O T E !!!
15872 !
15873 ! To save time the factor EXPON has been extracted from ALL components
15874 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15875 ! use!
15876 !
15877 !******************************************************************************
15878       return
15879       end subroutine escp_short
15880 !-----------------------------------------------------------------------------
15881 ! energy_p_new-sep_barrier.F
15882 !-----------------------------------------------------------------------------
15883       subroutine sc_grad_scale(scalfac)
15884 !      implicit real*8 (a-h,o-z)
15885       use calc_data
15886 !      include 'DIMENSIONS'
15887 !      include 'COMMON.CHAIN'
15888 !      include 'COMMON.DERIV'
15889 !      include 'COMMON.CALC'
15890 !      include 'COMMON.IOUNITS'
15891       real(kind=8),dimension(3) :: dcosom1,dcosom2
15892       real(kind=8) :: scalfac
15893 !el local variables
15894 !      integer :: i,j,k,l
15895
15896       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15897       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15898       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15899            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15900 ! diagnostics only
15901 !      eom1=0.0d0
15902 !      eom2=0.0d0
15903 !      eom12=evdwij*eps1_om12
15904 ! end diagnostics
15905 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15906 !     &  " sigder",sigder
15907 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15908 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15909       do k=1,3
15910         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15911         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15912       enddo
15913       do k=1,3
15914         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15915          *sss_ele_cut
15916       enddo
15917 !      write (iout,*) "gg",(gg(k),k=1,3)
15918       do k=1,3
15919         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15920                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15921                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15922                  *sss_ele_cut
15923         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15924                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15925                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15926          *sss_ele_cut
15927 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15928 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15929 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15930 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15931       enddo
15932 !
15933 ! Calculate the components of the gradient in DC and X
15934 !
15935       do l=1,3
15936         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15937         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15938       enddo
15939       return
15940       end subroutine sc_grad_scale
15941 !-----------------------------------------------------------------------------
15942 ! energy_split-sep.F
15943 !-----------------------------------------------------------------------------
15944       subroutine etotal_long(energia)
15945 !
15946 ! Compute the long-range slow-varying contributions to the energy
15947 !
15948 !      implicit real*8 (a-h,o-z)
15949 !      include 'DIMENSIONS'
15950       use MD_data, only: totT,usampl,eq_time
15951 #ifndef ISNAN
15952       external proc_proc
15953 #ifdef WINPGI
15954 !MS$ATTRIBUTES C ::  proc_proc
15955 #endif
15956 #endif
15957 #ifdef MPI
15958       include "mpif.h"
15959       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15960 #endif
15961 !      include 'COMMON.SETUP'
15962 !      include 'COMMON.IOUNITS'
15963 !      include 'COMMON.FFIELD'
15964 !      include 'COMMON.DERIV'
15965 !      include 'COMMON.INTERACT'
15966 !      include 'COMMON.SBRIDGE'
15967 !      include 'COMMON.CHAIN'
15968 !      include 'COMMON.VAR'
15969 !      include 'COMMON.LOCAL'
15970 !      include 'COMMON.MD'
15971       real(kind=8),dimension(0:n_ene) :: energia
15972 !el local variables
15973       integer :: i,n_corr,n_corr1,ierror,ierr
15974       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15975                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15976                   ecorr,ecorr5,ecorr6,eturn6,time00
15977 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15978 !elwrite(iout,*)"in etotal long"
15979
15980       if (modecalc.eq.12.or.modecalc.eq.14) then
15981 #ifdef MPI
15982 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15983 #else
15984         call int_from_cart1(.false.)
15985 #endif
15986       endif
15987 !elwrite(iout,*)"in etotal long"
15988
15989 #ifdef MPI
15990 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15991 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15992       call flush(iout)
15993       if (nfgtasks.gt.1) then
15994         time00=MPI_Wtime()
15995 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15996         if (fg_rank.eq.0) then
15997           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15998 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15999 !          call flush(iout)
16000 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16001 ! FG slaves as WEIGHTS array.
16002           weights_(1)=wsc
16003           weights_(2)=wscp
16004           weights_(3)=welec
16005           weights_(4)=wcorr
16006           weights_(5)=wcorr5
16007           weights_(6)=wcorr6
16008           weights_(7)=wel_loc
16009           weights_(8)=wturn3
16010           weights_(9)=wturn4
16011           weights_(10)=wturn6
16012           weights_(11)=wang
16013           weights_(12)=wscloc
16014           weights_(13)=wtor
16015           weights_(14)=wtor_d
16016           weights_(15)=wstrain
16017           weights_(16)=wvdwpp
16018           weights_(17)=wbond
16019           weights_(18)=scal14
16020           weights_(21)=wsccor
16021 ! FG Master broadcasts the WEIGHTS_ array
16022           call MPI_Bcast(weights_(1),n_ene,&
16023               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16024         else
16025 ! FG slaves receive the WEIGHTS array
16026           call MPI_Bcast(weights(1),n_ene,&
16027               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16028           wsc=weights(1)
16029           wscp=weights(2)
16030           welec=weights(3)
16031           wcorr=weights(4)
16032           wcorr5=weights(5)
16033           wcorr6=weights(6)
16034           wel_loc=weights(7)
16035           wturn3=weights(8)
16036           wturn4=weights(9)
16037           wturn6=weights(10)
16038           wang=weights(11)
16039           wscloc=weights(12)
16040           wtor=weights(13)
16041           wtor_d=weights(14)
16042           wstrain=weights(15)
16043           wvdwpp=weights(16)
16044           wbond=weights(17)
16045           scal14=weights(18)
16046           wsccor=weights(21)
16047         endif
16048         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16049           king,FG_COMM,IERR)
16050          time_Bcast=time_Bcast+MPI_Wtime()-time00
16051          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16052 !        call chainbuild_cart
16053 !        call int_from_cart1(.false.)
16054       endif
16055 !      write (iout,*) 'Processor',myrank,
16056 !     &  ' calling etotal_short ipot=',ipot
16057 !      call flush(iout)
16058 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16059 #endif
16060 !d    print *,'nnt=',nnt,' nct=',nct
16061 !
16062 !elwrite(iout,*)"in etotal long"
16063 ! Compute the side-chain and electrostatic interaction energy
16064 !
16065       goto (101,102,103,104,105,106) ipot
16066 ! Lennard-Jones potential.
16067   101 call elj_long(evdw)
16068 !d    print '(a)','Exit ELJ'
16069       goto 107
16070 ! Lennard-Jones-Kihara potential (shifted).
16071   102 call eljk_long(evdw)
16072       goto 107
16073 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16074   103 call ebp_long(evdw)
16075       goto 107
16076 ! Gay-Berne potential (shifted LJ, angular dependence).
16077   104 call egb_long(evdw)
16078       goto 107
16079 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16080   105 call egbv_long(evdw)
16081       goto 107
16082 ! Soft-sphere potential
16083   106 call e_softsphere(evdw)
16084 !
16085 ! Calculate electrostatic (H-bonding) energy of the main chain.
16086 !
16087   107 continue
16088       call vec_and_deriv
16089       if (ipot.lt.6) then
16090 #ifdef SPLITELE
16091          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16092              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16093              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16094              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16095 #else
16096          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16097              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16098              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16099              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16100 #endif
16101            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16102          else
16103             ees=0
16104             evdw1=0
16105             eel_loc=0
16106             eello_turn3=0
16107             eello_turn4=0
16108          endif
16109       else
16110 !        write (iout,*) "Soft-spheer ELEC potential"
16111         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16112          eello_turn4)
16113       endif
16114 !
16115 ! Calculate excluded-volume interaction energy between peptide groups
16116 ! and side chains.
16117 !
16118       if (ipot.lt.6) then
16119        if(wscp.gt.0d0) then
16120         call escp_long(evdw2,evdw2_14)
16121        else
16122         evdw2=0
16123         evdw2_14=0
16124        endif
16125       else
16126         call escp_soft_sphere(evdw2,evdw2_14)
16127       endif
16128 !
16129 ! 12/1/95 Multi-body terms
16130 !
16131       n_corr=0
16132       n_corr1=0
16133       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16134           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16135          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16136 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16137 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16138       else
16139          ecorr=0.0d0
16140          ecorr5=0.0d0
16141          ecorr6=0.0d0
16142          eturn6=0.0d0
16143       endif
16144       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16145          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16146       endif
16147 !
16148 ! If performing constraint dynamics, call the constraint energy
16149 !  after the equilibration time
16150       if(usampl.and.totT.gt.eq_time) then
16151          call EconstrQ
16152          call Econstr_back
16153       else
16154          Uconst=0.0d0
16155          Uconst_back=0.0d0
16156       endif
16157 !
16158 ! Sum the energies
16159 !
16160       do i=1,n_ene
16161         energia(i)=0.0d0
16162       enddo
16163       energia(1)=evdw
16164 #ifdef SCP14
16165       energia(2)=evdw2-evdw2_14
16166       energia(18)=evdw2_14
16167 #else
16168       energia(2)=evdw2
16169       energia(18)=0.0d0
16170 #endif
16171 #ifdef SPLITELE
16172       energia(3)=ees
16173       energia(16)=evdw1
16174 #else
16175       energia(3)=ees+evdw1
16176       energia(16)=0.0d0
16177 #endif
16178       energia(4)=ecorr
16179       energia(5)=ecorr5
16180       energia(6)=ecorr6
16181       energia(7)=eel_loc
16182       energia(8)=eello_turn3
16183       energia(9)=eello_turn4
16184       energia(10)=eturn6
16185       energia(20)=Uconst+Uconst_back
16186       call sum_energy(energia,.true.)
16187 !      write (iout,*) "Exit ETOTAL_LONG"
16188       call flush(iout)
16189       return
16190       end subroutine etotal_long
16191 !-----------------------------------------------------------------------------
16192       subroutine etotal_short(energia)
16193 !
16194 ! Compute the short-range fast-varying contributions to the energy
16195 !
16196 !      implicit real*8 (a-h,o-z)
16197 !      include 'DIMENSIONS'
16198 #ifndef ISNAN
16199       external proc_proc
16200 #ifdef WINPGI
16201 !MS$ATTRIBUTES C ::  proc_proc
16202 #endif
16203 #endif
16204 #ifdef MPI
16205       include "mpif.h"
16206       integer :: ierror,ierr
16207       real(kind=8),dimension(n_ene) :: weights_
16208       real(kind=8) :: time00
16209 #endif
16210 !      include 'COMMON.SETUP'
16211 !      include 'COMMON.IOUNITS'
16212 !      include 'COMMON.FFIELD'
16213 !      include 'COMMON.DERIV'
16214 !      include 'COMMON.INTERACT'
16215 !      include 'COMMON.SBRIDGE'
16216 !      include 'COMMON.CHAIN'
16217 !      include 'COMMON.VAR'
16218 !      include 'COMMON.LOCAL'
16219       real(kind=8),dimension(0:n_ene) :: energia
16220 !el local variables
16221       integer :: i,nres6
16222       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16223       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16224       nres6=6*nres
16225
16226 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16227 !      call flush(iout)
16228       if (modecalc.eq.12.or.modecalc.eq.14) then
16229 #ifdef MPI
16230         if (fg_rank.eq.0) call int_from_cart1(.false.)
16231 #else
16232         call int_from_cart1(.false.)
16233 #endif
16234       endif
16235 #ifdef MPI
16236 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16237 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16238 !      call flush(iout)
16239       if (nfgtasks.gt.1) then
16240         time00=MPI_Wtime()
16241 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16242         if (fg_rank.eq.0) then
16243           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16244 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16245 !          call flush(iout)
16246 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16247 ! FG slaves as WEIGHTS array.
16248           weights_(1)=wsc
16249           weights_(2)=wscp
16250           weights_(3)=welec
16251           weights_(4)=wcorr
16252           weights_(5)=wcorr5
16253           weights_(6)=wcorr6
16254           weights_(7)=wel_loc
16255           weights_(8)=wturn3
16256           weights_(9)=wturn4
16257           weights_(10)=wturn6
16258           weights_(11)=wang
16259           weights_(12)=wscloc
16260           weights_(13)=wtor
16261           weights_(14)=wtor_d
16262           weights_(15)=wstrain
16263           weights_(16)=wvdwpp
16264           weights_(17)=wbond
16265           weights_(18)=scal14
16266           weights_(21)=wsccor
16267 ! FG Master broadcasts the WEIGHTS_ array
16268           call MPI_Bcast(weights_(1),n_ene,&
16269               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16270         else
16271 ! FG slaves receive the WEIGHTS array
16272           call MPI_Bcast(weights(1),n_ene,&
16273               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16274           wsc=weights(1)
16275           wscp=weights(2)
16276           welec=weights(3)
16277           wcorr=weights(4)
16278           wcorr5=weights(5)
16279           wcorr6=weights(6)
16280           wel_loc=weights(7)
16281           wturn3=weights(8)
16282           wturn4=weights(9)
16283           wturn6=weights(10)
16284           wang=weights(11)
16285           wscloc=weights(12)
16286           wtor=weights(13)
16287           wtor_d=weights(14)
16288           wstrain=weights(15)
16289           wvdwpp=weights(16)
16290           wbond=weights(17)
16291           scal14=weights(18)
16292           wsccor=weights(21)
16293         endif
16294 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16295         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16296           king,FG_COMM,IERR)
16297 !        write (iout,*) "Processor",myrank," BROADCAST c"
16298         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16299           king,FG_COMM,IERR)
16300 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16301         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16302           king,FG_COMM,IERR)
16303 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16304         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16305           king,FG_COMM,IERR)
16306 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16307         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16308           king,FG_COMM,IERR)
16309 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16310         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16311           king,FG_COMM,IERR)
16312 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16313         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16314           king,FG_COMM,IERR)
16315 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16316         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16317           king,FG_COMM,IERR)
16318 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16319         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16320           king,FG_COMM,IERR)
16321          time_Bcast=time_Bcast+MPI_Wtime()-time00
16322 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16323       endif
16324 !      write (iout,*) 'Processor',myrank,
16325 !     &  ' calling etotal_short ipot=',ipot
16326 !      call flush(iout)
16327 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16328 #endif
16329 !      call int_from_cart1(.false.)
16330 !
16331 ! Compute the side-chain and electrostatic interaction energy
16332 !
16333       goto (101,102,103,104,105,106) ipot
16334 ! Lennard-Jones potential.
16335   101 call elj_short(evdw)
16336 !d    print '(a)','Exit ELJ'
16337       goto 107
16338 ! Lennard-Jones-Kihara potential (shifted).
16339   102 call eljk_short(evdw)
16340       goto 107
16341 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16342   103 call ebp_short(evdw)
16343       goto 107
16344 ! Gay-Berne potential (shifted LJ, angular dependence).
16345   104 call egb_short(evdw)
16346       goto 107
16347 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16348   105 call egbv_short(evdw)
16349       goto 107
16350 ! Soft-sphere potential - already dealt with in the long-range part
16351   106 evdw=0.0d0
16352 !  106 call e_softsphere_short(evdw)
16353 !
16354 ! Calculate electrostatic (H-bonding) energy of the main chain.
16355 !
16356   107 continue
16357 !
16358 ! Calculate the short-range part of Evdwpp
16359 !
16360       call evdwpp_short(evdw1)
16361 !
16362 ! Calculate the short-range part of ESCp
16363 !
16364       if (ipot.lt.6) then
16365         call escp_short(evdw2,evdw2_14)
16366       endif
16367 !
16368 ! Calculate the bond-stretching energy
16369 !
16370       call ebond(estr)
16371 !
16372 ! Calculate the disulfide-bridge and other energy and the contributions
16373 ! from other distance constraints.
16374       call edis(ehpb)
16375 !
16376 ! Calculate the virtual-bond-angle energy.
16377 !
16378 ! Calculate the SC local energy.
16379 !
16380       call vec_and_deriv
16381       call esc(escloc)
16382 !
16383       if (wang.gt.0d0) then
16384        if (tor_mode.eq.0) then
16385          call ebend(ebe)
16386        else
16387 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16388 !C energy function
16389          call ebend_kcc(ebe)
16390        endif
16391       else
16392         ebe=0.0d0
16393       endif
16394       ethetacnstr=0.0d0
16395       if (with_theta_constr) call etheta_constr(ethetacnstr)
16396
16397 !       write(iout,*) "in etotal afer ebe",ipot
16398
16399 !      print *,"Processor",myrank," computed UB"
16400 !
16401 ! Calculate the SC local energy.
16402 !
16403       call esc(escloc)
16404 !elwrite(iout,*) "in etotal afer esc",ipot
16405 !      print *,"Processor",myrank," computed USC"
16406 !
16407 ! Calculate the virtual-bond torsional energy.
16408 !
16409 !d    print *,'nterm=',nterm
16410 !      if (wtor.gt.0) then
16411 !       call etor(etors,edihcnstr)
16412 !      else
16413 !       etors=0
16414 !       edihcnstr=0
16415 !      endif
16416       if (wtor.gt.0.0d0) then
16417          if (tor_mode.eq.0) then
16418            call etor(etors)
16419          else
16420 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16421 !C energy function
16422            call etor_kcc(etors)
16423          endif
16424       else
16425         etors=0.0d0
16426       endif
16427       edihcnstr=0.0d0
16428       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16429
16430 ! Calculate the virtual-bond torsional energy.
16431 !
16432 !
16433 ! 6/23/01 Calculate double-torsional energy
16434 !
16435       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16436       call etor_d(etors_d)
16437       endif
16438 !
16439 ! 21/5/07 Calculate local sicdechain correlation energy
16440 !
16441       if (wsccor.gt.0.0d0) then
16442         call eback_sc_corr(esccor)
16443       else
16444         esccor=0.0d0
16445       endif
16446 !
16447 ! Put energy components into an array
16448 !
16449       do i=1,n_ene
16450         energia(i)=0.0d0
16451       enddo
16452       energia(1)=evdw
16453 #ifdef SCP14
16454       energia(2)=evdw2-evdw2_14
16455       energia(18)=evdw2_14
16456 #else
16457       energia(2)=evdw2
16458       energia(18)=0.0d0
16459 #endif
16460 #ifdef SPLITELE
16461       energia(16)=evdw1
16462 #else
16463       energia(3)=evdw1
16464 #endif
16465       energia(11)=ebe
16466       energia(12)=escloc
16467       energia(13)=etors
16468       energia(14)=etors_d
16469       energia(15)=ehpb
16470       energia(17)=estr
16471       energia(19)=edihcnstr
16472       energia(21)=esccor
16473 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16474       call flush(iout)
16475       call sum_energy(energia,.true.)
16476 !      write (iout,*) "Exit ETOTAL_SHORT"
16477       call flush(iout)
16478       return
16479       end subroutine etotal_short
16480 !-----------------------------------------------------------------------------
16481 ! gnmr1.f
16482 !-----------------------------------------------------------------------------
16483       real(kind=8) function gnmr1(y,ymin,ymax)
16484 !      implicit none
16485       real(kind=8) :: y,ymin,ymax
16486       real(kind=8) :: wykl=4.0d0
16487       if (y.lt.ymin) then
16488         gnmr1=(ymin-y)**wykl/wykl
16489       else if (y.gt.ymax) then
16490         gnmr1=(y-ymax)**wykl/wykl
16491       else
16492         gnmr1=0.0d0
16493       endif
16494       return
16495       end function gnmr1
16496 !-----------------------------------------------------------------------------
16497       real(kind=8) function gnmr1prim(y,ymin,ymax)
16498 !      implicit none
16499       real(kind=8) :: y,ymin,ymax
16500       real(kind=8) :: wykl=4.0d0
16501       if (y.lt.ymin) then
16502         gnmr1prim=-(ymin-y)**(wykl-1)
16503       else if (y.gt.ymax) then
16504         gnmr1prim=(y-ymax)**(wykl-1)
16505       else
16506         gnmr1prim=0.0d0
16507       endif
16508       return
16509       end function gnmr1prim
16510 !----------------------------------------------------------------------------
16511       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16512       real(kind=8) y,ymin,ymax,sigma
16513       real(kind=8) wykl /4.0d0/
16514       if (y.lt.ymin) then
16515         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16516       else if (y.gt.ymax) then
16517         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16518       else
16519         rlornmr1=0.0d0
16520       endif
16521       return
16522       end function rlornmr1
16523 !------------------------------------------------------------------------------
16524       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16525       real(kind=8) y,ymin,ymax,sigma
16526       real(kind=8) wykl /4.0d0/
16527       if (y.lt.ymin) then
16528         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16529         ((ymin-y)**wykl+sigma**wykl)**2
16530       else if (y.gt.ymax) then
16531         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16532         ((y-ymax)**wykl+sigma**wykl)**2
16533       else
16534         rlornmr1prim=0.0d0
16535       endif
16536       return
16537       end function rlornmr1prim
16538
16539       real(kind=8) function harmonic(y,ymax)
16540 !      implicit none
16541       real(kind=8) :: y,ymax
16542       real(kind=8) :: wykl=2.0d0
16543       harmonic=(y-ymax)**wykl
16544       return
16545       end function harmonic
16546 !-----------------------------------------------------------------------------
16547       real(kind=8) function harmonicprim(y,ymax)
16548       real(kind=8) :: y,ymin,ymax
16549       real(kind=8) :: wykl=2.0d0
16550       harmonicprim=(y-ymax)*wykl
16551       return
16552       end function harmonicprim
16553 !-----------------------------------------------------------------------------
16554 ! gradient_p.F
16555 !-----------------------------------------------------------------------------
16556       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16557
16558       use io_base, only:intout,briefout
16559 !      implicit real*8 (a-h,o-z)
16560 !      include 'DIMENSIONS'
16561 !      include 'COMMON.CHAIN'
16562 !      include 'COMMON.DERIV'
16563 !      include 'COMMON.VAR'
16564 !      include 'COMMON.INTERACT'
16565 !      include 'COMMON.FFIELD'
16566 !      include 'COMMON.MD'
16567 !      include 'COMMON.IOUNITS'
16568       real(kind=8),external :: ufparm
16569       integer :: uiparm(1)
16570       real(kind=8) :: urparm(1)
16571       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16572       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16573       integer :: n,nf,ind,ind1,i,k,j
16574 !
16575 ! This subroutine calculates total internal coordinate gradient.
16576 ! Depending on the number of function evaluations, either whole energy
16577 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16578 ! internal coordinates are reevaluated or only the cartesian-in-internal
16579 ! coordinate derivatives are evaluated. The subroutine was designed to work
16580 ! with SUMSL.
16581 !
16582 !
16583       icg=mod(nf,2)+1
16584
16585 !d      print *,'grad',nf,icg
16586       if (nf-nfl+1) 20,30,40
16587    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16588 !    write (iout,*) 'grad 20'
16589       if (nf.eq.0) return
16590       goto 40
16591    30 call var_to_geom(n,x)
16592       call chainbuild
16593 !    write (iout,*) 'grad 30'
16594 !
16595 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16596 !
16597    40 call cartder
16598 !     write (iout,*) 'grad 40'
16599 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16600 !
16601 ! Convert the Cartesian gradient into internal-coordinate gradient.
16602 !
16603       ind=0
16604       ind1=0
16605       do i=1,nres-2
16606       gthetai=0.0D0
16607       gphii=0.0D0
16608       do j=i+1,nres-1
16609           ind=ind+1
16610 !         ind=indmat(i,j)
16611 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16612         do k=1,3
16613             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16614           enddo
16615         do k=1,3
16616           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16617           enddo
16618         enddo
16619       do j=i+1,nres-1
16620           ind1=ind1+1
16621 !         ind1=indmat(i,j)
16622 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16623         do k=1,3
16624           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16625           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16626           enddo
16627         enddo
16628       if (i.gt.1) g(i-1)=gphii
16629       if (n.gt.nphi) g(nphi+i)=gthetai
16630       enddo
16631       if (n.le.nphi+ntheta) goto 10
16632       do i=2,nres-1
16633       if (itype(i,1).ne.10) then
16634           galphai=0.0D0
16635         gomegai=0.0D0
16636         do k=1,3
16637           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16638           enddo
16639         do k=1,3
16640           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16641           enddo
16642           g(ialph(i,1))=galphai
16643         g(ialph(i,1)+nside)=gomegai
16644         endif
16645       enddo
16646 !
16647 ! Add the components corresponding to local energy terms.
16648 !
16649    10 continue
16650       do i=1,nvar
16651 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16652         g(i)=g(i)+gloc(i,icg)
16653       enddo
16654 ! Uncomment following three lines for diagnostics.
16655 !d    call intout
16656 !elwrite(iout,*) "in gradient after calling intout"
16657 !d    call briefout(0,0.0d0)
16658 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16659       return
16660       end subroutine gradient
16661 !-----------------------------------------------------------------------------
16662       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16663
16664       use comm_chu
16665 !      implicit real*8 (a-h,o-z)
16666 !      include 'DIMENSIONS'
16667 !      include 'COMMON.DERIV'
16668 !      include 'COMMON.IOUNITS'
16669 !      include 'COMMON.GEO'
16670       integer :: n,nf
16671 !el      integer :: jjj
16672 !el      common /chuju/ jjj
16673       real(kind=8) :: energia(0:n_ene)
16674       integer :: uiparm(1)
16675       real(kind=8) :: urparm(1)
16676       real(kind=8) :: f
16677       real(kind=8),external :: ufparm
16678       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16679 !     if (jjj.gt.0) then
16680 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16681 !     endif
16682       nfl=nf
16683       icg=mod(nf,2)+1
16684 !d      print *,'func',nf,nfl,icg
16685       call var_to_geom(n,x)
16686       call zerograd
16687       call chainbuild
16688 !d    write (iout,*) 'ETOTAL called from FUNC'
16689       call etotal(energia)
16690       call sum_gradient
16691       f=energia(0)
16692 !     if (jjj.gt.0) then
16693 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16694 !       write (iout,*) 'f=',etot
16695 !       jjj=0
16696 !     endif
16697       return
16698       end subroutine func
16699 !-----------------------------------------------------------------------------
16700       subroutine cartgrad
16701 !      implicit real*8 (a-h,o-z)
16702 !      include 'DIMENSIONS'
16703       use energy_data
16704       use MD_data, only: totT,usampl,eq_time
16705 #ifdef MPI
16706       include 'mpif.h'
16707 #endif
16708 !      include 'COMMON.CHAIN'
16709 !      include 'COMMON.DERIV'
16710 !      include 'COMMON.VAR'
16711 !      include 'COMMON.INTERACT'
16712 !      include 'COMMON.FFIELD'
16713 !      include 'COMMON.MD'
16714 !      include 'COMMON.IOUNITS'
16715 !      include 'COMMON.TIME1'
16716 !
16717       integer :: i,j
16718
16719 ! This subrouting calculates total Cartesian coordinate gradient.
16720 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16721 !
16722 !#define DEBUG
16723 #ifdef TIMING
16724       time00=MPI_Wtime()
16725 #endif
16726       icg=1
16727       call sum_gradient
16728 #ifdef TIMING
16729 #endif
16730 !#define DEBUG
16731 !el      write (iout,*) "After sum_gradient"
16732 #ifdef DEBUG
16733       write (iout,*) "After sum_gradient"
16734       do i=1,nres-1
16735         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16736         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16737       enddo
16738 #endif
16739 !#undef DEBUG
16740 ! If performing constraint dynamics, add the gradients of the constraint energy
16741       if(usampl.and.totT.gt.eq_time) then
16742          do i=1,nct
16743            do j=1,3
16744              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16745              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16746            enddo
16747          enddo
16748          do i=1,nres-3
16749            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16750          enddo
16751          do i=1,nres-2
16752            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16753          enddo
16754       endif
16755 !elwrite (iout,*) "After sum_gradient"
16756 #ifdef TIMING
16757       time01=MPI_Wtime()
16758 #endif
16759       call intcartderiv
16760 !elwrite (iout,*) "After sum_gradient"
16761 #ifdef TIMING
16762       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16763 #endif
16764 !     call checkintcartgrad
16765 !     write(iout,*) 'calling int_to_cart'
16766 !#define DEBUG
16767 #ifdef DEBUG
16768       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16769 #endif
16770       do i=0,nct
16771         do j=1,3
16772           gcart(j,i)=gradc(j,i,icg)
16773           gxcart(j,i)=gradx(j,i,icg)
16774 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16775         enddo
16776 #ifdef DEBUG
16777         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16778           (gxcart(j,i),j=1,3),gloc(i,icg)
16779 #endif
16780       enddo
16781 #ifdef TIMING
16782       time01=MPI_Wtime()
16783 #endif
16784 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16785       call int_to_cart
16786 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16787
16788 #ifdef TIMING
16789             time_inttocart=time_inttocart+MPI_Wtime()-time01
16790 #endif
16791 #ifdef DEBUG
16792             write (iout,*) "gcart and gxcart after int_to_cart"
16793             do i=0,nres-1
16794             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16795                 (gxcart(j,i),j=1,3)
16796             enddo
16797 #endif
16798 !#undef DEBUG
16799 #ifdef CARGRAD
16800 #ifdef DEBUG
16801             write (iout,*) "CARGRAD"
16802 #endif
16803             do i=nres,0,-1
16804             do j=1,3
16805               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16806       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16807             enddo
16808       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16809       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16810             enddo
16811       ! Correction: dummy residues
16812             if (nnt.gt.1) then
16813               do j=1,3
16814       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16815                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16816               enddo
16817             endif
16818             if (nct.lt.nres) then
16819               do j=1,3
16820       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16821                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16822               enddo
16823             endif
16824 #endif
16825 #ifdef TIMING
16826             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16827 #endif
16828 !#undef DEBUG
16829             return
16830             end subroutine cartgrad
16831       !-----------------------------------------------------------------------------
16832             subroutine zerograd
16833       !      implicit real*8 (a-h,o-z)
16834       !      include 'DIMENSIONS'
16835       !      include 'COMMON.DERIV'
16836       !      include 'COMMON.CHAIN'
16837       !      include 'COMMON.VAR'
16838       !      include 'COMMON.MD'
16839       !      include 'COMMON.SCCOR'
16840       !
16841       !el local variables
16842             integer :: i,j,intertyp,k
16843       ! Initialize Cartesian-coordinate gradient
16844       !
16845       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16846       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16847
16848       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16849       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16850       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16851       !      allocate(gradcorr_long(3,nres))
16852       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16853       !      allocate(gcorr6_turn_long(3,nres))
16854       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16855
16856       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16857
16858       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16859       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16860
16861       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16862       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16863
16864       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16865       !      allocate(gscloc(3,nres)) !(3,maxres)
16866       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16867
16868
16869
16870       !      common /deriv_scloc/
16871       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16872       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16873       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16874       !      common /mpgrad/
16875       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16876
16877
16878
16879       !          gradc(j,i,icg)=0.0d0
16880       !          gradx(j,i,icg)=0.0d0
16881
16882       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16883       !elwrite(iout,*) "icg",icg
16884             do i=-1,nres
16885             do j=1,3
16886               gvdwx(j,i)=0.0D0
16887               gradx_scp(j,i)=0.0D0
16888               gvdwc(j,i)=0.0D0
16889               gvdwc_scp(j,i)=0.0D0
16890               gvdwc_scpp(j,i)=0.0d0
16891               gelc(j,i)=0.0D0
16892               gelc_long(j,i)=0.0D0
16893               gradb(j,i)=0.0d0
16894               gradbx(j,i)=0.0d0
16895               gvdwpp(j,i)=0.0d0
16896               gel_loc(j,i)=0.0d0
16897               gel_loc_long(j,i)=0.0d0
16898               ghpbc(j,i)=0.0D0
16899               ghpbx(j,i)=0.0D0
16900               gcorr3_turn(j,i)=0.0d0
16901               gcorr4_turn(j,i)=0.0d0
16902               gradcorr(j,i)=0.0d0
16903               gradcorr_long(j,i)=0.0d0
16904               gradcorr5_long(j,i)=0.0d0
16905               gradcorr6_long(j,i)=0.0d0
16906               gcorr6_turn_long(j,i)=0.0d0
16907               gradcorr5(j,i)=0.0d0
16908               gradcorr6(j,i)=0.0d0
16909               gcorr6_turn(j,i)=0.0d0
16910               gsccorc(j,i)=0.0d0
16911               gsccorx(j,i)=0.0d0
16912               gradc(j,i,icg)=0.0d0
16913               gradx(j,i,icg)=0.0d0
16914               gscloc(j,i)=0.0d0
16915               gsclocx(j,i)=0.0d0
16916               gliptran(j,i)=0.0d0
16917               gliptranx(j,i)=0.0d0
16918               gliptranc(j,i)=0.0d0
16919               gshieldx(j,i)=0.0d0
16920               gshieldc(j,i)=0.0d0
16921               gshieldc_loc(j,i)=0.0d0
16922               gshieldx_ec(j,i)=0.0d0
16923               gshieldc_ec(j,i)=0.0d0
16924               gshieldc_loc_ec(j,i)=0.0d0
16925               gshieldx_t3(j,i)=0.0d0
16926               gshieldc_t3(j,i)=0.0d0
16927               gshieldc_loc_t3(j,i)=0.0d0
16928               gshieldx_t4(j,i)=0.0d0
16929               gshieldc_t4(j,i)=0.0d0
16930               gshieldc_loc_t4(j,i)=0.0d0
16931               gshieldx_ll(j,i)=0.0d0
16932               gshieldc_ll(j,i)=0.0d0
16933               gshieldc_loc_ll(j,i)=0.0d0
16934               gg_tube(j,i)=0.0d0
16935               gg_tube_sc(j,i)=0.0d0
16936               gradafm(j,i)=0.0d0
16937               gradb_nucl(j,i)=0.0d0
16938               gradbx_nucl(j,i)=0.0d0
16939               gvdwpp_nucl(j,i)=0.0d0
16940               gvdwpp(j,i)=0.0d0
16941               gelpp(j,i)=0.0d0
16942               gvdwpsb(j,i)=0.0d0
16943               gvdwpsb1(j,i)=0.0d0
16944               gvdwsbc(j,i)=0.0d0
16945               gvdwsbx(j,i)=0.0d0
16946               gelsbc(j,i)=0.0d0
16947               gradcorr_nucl(j,i)=0.0d0
16948               gradcorr3_nucl(j,i)=0.0d0
16949               gradxorr_nucl(j,i)=0.0d0
16950               gradxorr3_nucl(j,i)=0.0d0
16951               gelsbx(j,i)=0.0d0
16952               gsbloc(j,i)=0.0d0
16953               gsblocx(j,i)=0.0d0
16954               gradpepcat(j,i)=0.0d0
16955               gradpepcatx(j,i)=0.0d0
16956               gradcatcat(j,i)=0.0d0
16957               gvdwx_scbase(j,i)=0.0d0
16958               gvdwc_scbase(j,i)=0.0d0
16959               gvdwx_pepbase(j,i)=0.0d0
16960               gvdwc_pepbase(j,i)=0.0d0
16961               gvdwx_scpho(j,i)=0.0d0
16962               gvdwc_scpho(j,i)=0.0d0
16963               gvdwc_peppho(j,i)=0.0d0
16964             enddo
16965              enddo
16966             do i=0,nres
16967             do j=1,3
16968               do intertyp=1,3
16969                gloc_sc(intertyp,i,icg)=0.0d0
16970               enddo
16971             enddo
16972             enddo
16973             do i=1,nres
16974              do j=1,maxcontsshi
16975              shield_list(j,i)=0
16976             do k=1,3
16977       !C           print *,i,j,k
16978                grad_shield_side(k,j,i)=0.0d0
16979                grad_shield_loc(k,j,i)=0.0d0
16980              enddo
16981              enddo
16982              ishield_list(i)=0
16983             enddo
16984
16985       !
16986       ! Initialize the gradient of local energy terms.
16987       !
16988       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16989       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16990       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16991       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16992       !      allocate(gel_loc_turn3(nres))
16993       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16994       !      allocate(gsccor_loc(nres))      !(maxres)
16995
16996             do i=1,4*nres
16997             gloc(i,icg)=0.0D0
16998             enddo
16999             do i=1,nres
17000             gel_loc_loc(i)=0.0d0
17001             gcorr_loc(i)=0.0d0
17002             g_corr5_loc(i)=0.0d0
17003             g_corr6_loc(i)=0.0d0
17004             gel_loc_turn3(i)=0.0d0
17005             gel_loc_turn4(i)=0.0d0
17006             gel_loc_turn6(i)=0.0d0
17007             gsccor_loc(i)=0.0d0
17008             enddo
17009       ! initialize gcart and gxcart
17010       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17011             do i=0,nres
17012             do j=1,3
17013               gcart(j,i)=0.0d0
17014               gxcart(j,i)=0.0d0
17015             enddo
17016             enddo
17017             return
17018             end subroutine zerograd
17019       !-----------------------------------------------------------------------------
17020             real(kind=8) function fdum()
17021             fdum=0.0D0
17022             return
17023             end function fdum
17024       !-----------------------------------------------------------------------------
17025       ! intcartderiv.F
17026       !-----------------------------------------------------------------------------
17027             subroutine intcartderiv
17028       !      implicit real*8 (a-h,o-z)
17029       !      include 'DIMENSIONS'
17030 #ifdef MPI
17031             include 'mpif.h'
17032 #endif
17033       !      include 'COMMON.SETUP'
17034       !      include 'COMMON.CHAIN'
17035       !      include 'COMMON.VAR'
17036       !      include 'COMMON.GEO'
17037       !      include 'COMMON.INTERACT'
17038       !      include 'COMMON.DERIV'
17039       !      include 'COMMON.IOUNITS'
17040       !      include 'COMMON.LOCAL'
17041       !      include 'COMMON.SCCOR'
17042             real(kind=8) :: pi4,pi34
17043             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17044             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17045                       dcosomega,dsinomega !(3,3,maxres)
17046             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17047
17048             integer :: i,j,k
17049             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17050                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17051                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17052                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17053             integer :: nres2
17054             nres2=2*nres
17055
17056       !el from module energy-------------
17057       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17058       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17059       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17060
17061       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17062       !el      allocate(dsintau(3,3,3,0:nres2))
17063       !el      allocate(dtauangle(3,3,3,0:nres2))
17064       !el      allocate(domicron(3,2,2,0:nres2))
17065       !el      allocate(dcosomicron(3,2,2,0:nres2))
17066
17067
17068
17069 #if defined(MPI) && defined(PARINTDER)
17070             if (nfgtasks.gt.1 .and. me.eq.king) &
17071             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17072 #endif
17073             pi4 = 0.5d0*pipol
17074             pi34 = 3*pi4
17075
17076       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17077       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17078
17079       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17080             do i=1,nres
17081             do j=1,3
17082               dtheta(j,1,i)=0.0d0
17083               dtheta(j,2,i)=0.0d0
17084               dphi(j,1,i)=0.0d0
17085               dphi(j,2,i)=0.0d0
17086               dphi(j,3,i)=0.0d0
17087               dcosomicron(j,1,1,i)=0.0d0
17088               dcosomicron(j,1,2,i)=0.0d0
17089               dcosomicron(j,2,1,i)=0.0d0
17090               dcosomicron(j,2,2,i)=0.0d0
17091             enddo
17092             enddo
17093       ! Derivatives of theta's
17094 #if defined(MPI) && defined(PARINTDER)
17095       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17096             do i=max0(ithet_start-1,3),ithet_end
17097 #else
17098             do i=3,nres
17099 #endif
17100             cost=dcos(theta(i))
17101             sint=sqrt(1-cost*cost)
17102             do j=1,3
17103               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17104               vbld(i-1)
17105               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17106               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17107               vbld(i)
17108               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17109             enddo
17110             enddo
17111 #if defined(MPI) && defined(PARINTDER)
17112       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17113             do i=max0(ithet_start-1,3),ithet_end
17114 #else
17115             do i=3,nres
17116 #endif
17117             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17118             cost1=dcos(omicron(1,i))
17119             sint1=sqrt(1-cost1*cost1)
17120             cost2=dcos(omicron(2,i))
17121             sint2=sqrt(1-cost2*cost2)
17122              do j=1,3
17123       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17124               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17125               cost1*dc_norm(j,i-2))/ &
17126               vbld(i-1)
17127               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17128               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17129               +cost1*(dc_norm(j,i-1+nres)))/ &
17130               vbld(i-1+nres)
17131               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17132       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17133       !C Looks messy but better than if in loop
17134               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17135               +cost2*dc_norm(j,i-1))/ &
17136               vbld(i)
17137               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17138               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17139                +cost2*(-dc_norm(j,i-1+nres)))/ &
17140               vbld(i-1+nres)
17141       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17142               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17143             enddo
17144              endif
17145             enddo
17146       !elwrite(iout,*) "after vbld write"
17147       ! Derivatives of phi:
17148       ! If phi is 0 or 180 degrees, then the formulas
17149       ! have to be derived by power series expansion of the
17150       ! conventional formulas around 0 and 180.
17151 #ifdef PARINTDER
17152             do i=iphi1_start,iphi1_end
17153 #else
17154             do i=4,nres
17155 #endif
17156       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17157       ! the conventional case
17158             sint=dsin(theta(i))
17159             sint1=dsin(theta(i-1))
17160             sing=dsin(phi(i))
17161             cost=dcos(theta(i))
17162             cost1=dcos(theta(i-1))
17163             cosg=dcos(phi(i))
17164             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17165             fac0=1.0d0/(sint1*sint)
17166             fac1=cost*fac0
17167             fac2=cost1*fac0
17168             fac3=cosg*cost1/(sint1*sint1)
17169             fac4=cosg*cost/(sint*sint)
17170       !    Obtaining the gamma derivatives from sine derivative
17171              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17172                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17173                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17174              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17175              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17176              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17177              do j=1,3
17178                 ctgt=cost/sint
17179                 ctgt1=cost1/sint1
17180                 cosg_inv=1.0d0/cosg
17181                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17182                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17183                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17184                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17185                 dsinphi(j,2,i)= &
17186                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17187                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17188                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17189                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17190                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17191       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17192                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17193                 endif
17194       ! Bug fixed 3/24/05 (AL)
17195              enddo
17196       !   Obtaining the gamma derivatives from cosine derivative
17197             else
17198                do j=1,3
17199                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17200                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17201                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17202                dc_norm(j,i-3))/vbld(i-2)
17203                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17204                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17205                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17206                dcostheta(j,1,i)
17207                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17208                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17209                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17210                dc_norm(j,i-1))/vbld(i)
17211                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17212 !#define DEBUG
17213 #ifdef DEBUG
17214                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17215 #endif
17216 !#undef DEBUG
17217                endif
17218              enddo
17219             endif
17220             enddo
17221       !alculate derivative of Tauangle
17222 #ifdef PARINTDER
17223             do i=itau_start,itau_end
17224 #else
17225             do i=3,nres
17226       !elwrite(iout,*) " vecpr",i,nres
17227 #endif
17228              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17229       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17230       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17231       !c dtauangle(j,intertyp,dervityp,residue number)
17232       !c INTERTYP=1 SC...Ca...Ca..Ca
17233       ! the conventional case
17234             sint=dsin(theta(i))
17235             sint1=dsin(omicron(2,i-1))
17236             sing=dsin(tauangle(1,i))
17237             cost=dcos(theta(i))
17238             cost1=dcos(omicron(2,i-1))
17239             cosg=dcos(tauangle(1,i))
17240       !elwrite(iout,*) " vecpr5",i,nres
17241             do j=1,3
17242       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17243       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17244             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17245       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17246             enddo
17247             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17248             fac0=1.0d0/(sint1*sint)
17249             fac1=cost*fac0
17250             fac2=cost1*fac0
17251             fac3=cosg*cost1/(sint1*sint1)
17252             fac4=cosg*cost/(sint*sint)
17253       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17254       !    Obtaining the gamma derivatives from sine derivative
17255              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17256                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17257                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17258              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17259              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17260              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17261             do j=1,3
17262                 ctgt=cost/sint
17263                 ctgt1=cost1/sint1
17264                 cosg_inv=1.0d0/cosg
17265                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17266              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17267              *vbld_inv(i-2+nres)
17268                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17269                 dsintau(j,1,2,i)= &
17270                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17271                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17272       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17273                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17274       ! Bug fixed 3/24/05 (AL)
17275                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17276                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17277       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17278                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17279              enddo
17280       !   Obtaining the gamma derivatives from cosine derivative
17281             else
17282                do j=1,3
17283                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17284                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17285                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17286                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17287                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17288                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17289                dcostheta(j,1,i)
17290                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17291                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17292                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17293                dc_norm(j,i-1))/vbld(i)
17294                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17295       !         write (iout,*) "else",i
17296              enddo
17297             endif
17298       !        do k=1,3
17299       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17300       !        enddo
17301             enddo
17302       !C Second case Ca...Ca...Ca...SC
17303 #ifdef PARINTDER
17304             do i=itau_start,itau_end
17305 #else
17306             do i=4,nres
17307 #endif
17308              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17309               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17310       ! the conventional case
17311             sint=dsin(omicron(1,i))
17312             sint1=dsin(theta(i-1))
17313             sing=dsin(tauangle(2,i))
17314             cost=dcos(omicron(1,i))
17315             cost1=dcos(theta(i-1))
17316             cosg=dcos(tauangle(2,i))
17317       !        do j=1,3
17318       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17319       !        enddo
17320             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17321             fac0=1.0d0/(sint1*sint)
17322             fac1=cost*fac0
17323             fac2=cost1*fac0
17324             fac3=cosg*cost1/(sint1*sint1)
17325             fac4=cosg*cost/(sint*sint)
17326       !    Obtaining the gamma derivatives from sine derivative
17327              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17328                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17329                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17330              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17331              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17332              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17333             do j=1,3
17334                 ctgt=cost/sint
17335                 ctgt1=cost1/sint1
17336                 cosg_inv=1.0d0/cosg
17337                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17338                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17339       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17340       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17341                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17342                 dsintau(j,2,2,i)= &
17343                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17344                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17345       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17346       !     & sing*ctgt*domicron(j,1,2,i),
17347       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17348                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17349       ! Bug fixed 3/24/05 (AL)
17350                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17351                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17352       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17353                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17354              enddo
17355       !   Obtaining the gamma derivatives from cosine derivative
17356             else
17357                do j=1,3
17358                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17359                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17360                dc_norm(j,i-3))/vbld(i-2)
17361                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17362                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17363                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17364                dcosomicron(j,1,1,i)
17365                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17366                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17367                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17368                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17369                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17370       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17371              enddo
17372             endif
17373             enddo
17374
17375       !CC third case SC...Ca...Ca...SC
17376 #ifdef PARINTDER
17377
17378             do i=itau_start,itau_end
17379 #else
17380             do i=3,nres
17381 #endif
17382       ! the conventional case
17383             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17384             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17385             sint=dsin(omicron(1,i))
17386             sint1=dsin(omicron(2,i-1))
17387             sing=dsin(tauangle(3,i))
17388             cost=dcos(omicron(1,i))
17389             cost1=dcos(omicron(2,i-1))
17390             cosg=dcos(tauangle(3,i))
17391             do j=1,3
17392             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17393       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17394             enddo
17395             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17396             fac0=1.0d0/(sint1*sint)
17397             fac1=cost*fac0
17398             fac2=cost1*fac0
17399             fac3=cosg*cost1/(sint1*sint1)
17400             fac4=cosg*cost/(sint*sint)
17401       !    Obtaining the gamma derivatives from sine derivative
17402              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17403                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17404                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17405              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17406              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17407              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17408             do j=1,3
17409                 ctgt=cost/sint
17410                 ctgt1=cost1/sint1
17411                 cosg_inv=1.0d0/cosg
17412                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17413                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17414                   *vbld_inv(i-2+nres)
17415                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17416                 dsintau(j,3,2,i)= &
17417                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17418                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17419                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17420       ! Bug fixed 3/24/05 (AL)
17421                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17422                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17423                   *vbld_inv(i-1+nres)
17424       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17425                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17426              enddo
17427       !   Obtaining the gamma derivatives from cosine derivative
17428             else
17429                do j=1,3
17430                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17431                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17432                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17433                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17434                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17435                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17436                dcosomicron(j,1,1,i)
17437                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17438                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17439                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17440                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17441                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17442       !          write(iout,*) "else",i
17443              enddo
17444             endif
17445             enddo
17446
17447 #ifdef CRYST_SC
17448       !   Derivatives of side-chain angles alpha and omega
17449 #if defined(MPI) && defined(PARINTDER)
17450             do i=ibond_start,ibond_end
17451 #else
17452             do i=2,nres-1
17453 #endif
17454               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17455                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17456                  fac6=fac5/vbld(i)
17457                  fac7=fac5*fac5
17458                  fac8=fac5/vbld(i+1)
17459                  fac9=fac5/vbld(i+nres)
17460                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17461                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17462                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17463                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17464                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17465                  sina=sqrt(1-cosa*cosa)
17466                  sino=dsin(omeg(i))
17467       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17468                  do j=1,3
17469                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17470                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17471                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17472                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17473                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17474                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17475                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17476                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17477                   vbld(i+nres))
17478                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17479                 enddo
17480       ! obtaining the derivatives of omega from sines
17481                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17482                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17483                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17484                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17485                    dsin(theta(i+1)))
17486                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17487                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17488                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17489                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17490                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17491                    coso_inv=1.0d0/dcos(omeg(i))
17492                    do j=1,3
17493                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17494                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17495                    (sino*dc_norm(j,i-1))/vbld(i)
17496                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17497                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17498                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17499                    -sino*dc_norm(j,i)/vbld(i+1)
17500                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17501                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17502                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17503                    vbld(i+nres)
17504                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17505                   enddo
17506                else
17507       !   obtaining the derivatives of omega from cosines
17508                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17509                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17510                  fac12=fac10*sina
17511                  fac13=fac12*fac12
17512                  fac14=sina*sina
17513                  do j=1,3
17514                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17515                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17516                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17517                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17518                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17519                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17520                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17521                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17522                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17523                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17524                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17525                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17526                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17527                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17528                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17529                 enddo
17530               endif
17531              else
17532                do j=1,3
17533                  do k=1,3
17534                    dalpha(k,j,i)=0.0d0
17535                    domega(k,j,i)=0.0d0
17536                  enddo
17537                enddo
17538              endif
17539              enddo
17540 #endif
17541 #if defined(MPI) && defined(PARINTDER)
17542             if (nfgtasks.gt.1) then
17543 #ifdef DEBUG
17544       !d      write (iout,*) "Gather dtheta"
17545       !d      call flush(iout)
17546             write (iout,*) "dtheta before gather"
17547             do i=1,nres
17548             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17549             enddo
17550 #endif
17551             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17552             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17553             king,FG_COMM,IERROR)
17554 !#define DEBUG
17555 #ifdef DEBUG
17556       !d      write (iout,*) "Gather dphi"
17557       !d      call flush(iout)
17558             write (iout,*) "dphi before gather"
17559             do i=1,nres
17560             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17561             enddo
17562 #endif
17563 !#undef DEBUG
17564             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17565             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17566             king,FG_COMM,IERROR)
17567       !d      write (iout,*) "Gather dalpha"
17568       !d      call flush(iout)
17569 #ifdef CRYST_SC
17570             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17571             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17572             king,FG_COMM,IERROR)
17573       !d      write (iout,*) "Gather domega"
17574       !d      call flush(iout)
17575             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17576             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17577             king,FG_COMM,IERROR)
17578 #endif
17579             endif
17580 #endif
17581 !#define DEBUG
17582 #ifdef DEBUG
17583             write (iout,*) "dtheta after gather"
17584             do i=1,nres
17585             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17586             enddo
17587             write (iout,*) "dphi after gather"
17588             do i=1,nres
17589             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17590             enddo
17591             write (iout,*) "dalpha after gather"
17592             do i=1,nres
17593             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17594             enddo
17595             write (iout,*) "domega after gather"
17596             do i=1,nres
17597             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17598             enddo
17599 #endif
17600 !#undef DEBUG
17601             return
17602             end subroutine intcartderiv
17603       !-----------------------------------------------------------------------------
17604             subroutine checkintcartgrad
17605       !      implicit real*8 (a-h,o-z)
17606       !      include 'DIMENSIONS'
17607 #ifdef MPI
17608             include 'mpif.h'
17609 #endif
17610       !      include 'COMMON.CHAIN'
17611       !      include 'COMMON.VAR'
17612       !      include 'COMMON.GEO'
17613       !      include 'COMMON.INTERACT'
17614       !      include 'COMMON.DERIV'
17615       !      include 'COMMON.IOUNITS'
17616       !      include 'COMMON.SETUP'
17617             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17618             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17619             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17620             real(kind=8),dimension(3) :: dc_norm_s
17621             real(kind=8) :: aincr=1.0d-5
17622             integer :: i,j
17623             real(kind=8) :: dcji
17624             do i=1,nres
17625             phi_s(i)=phi(i)
17626             theta_s(i)=theta(i)
17627             alph_s(i)=alph(i)
17628             omeg_s(i)=omeg(i)
17629             enddo
17630       ! Check theta gradient
17631             write (iout,*) &
17632              "Analytical (upper) and numerical (lower) gradient of theta"
17633             write (iout,*)
17634             do i=3,nres
17635             do j=1,3
17636               dcji=dc(j,i-2)
17637               dc(j,i-2)=dcji+aincr
17638               call chainbuild_cart
17639               call int_from_cart1(.false.)
17640           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17641           dc(j,i-2)=dcji
17642           dcji=dc(j,i-1)
17643           dc(j,i-1)=dc(j,i-1)+aincr
17644           call chainbuild_cart
17645           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17646           dc(j,i-1)=dcji
17647         enddo
17648 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17649 !el          (dtheta(j,2,i),j=1,3)
17650 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17651 !el          (dthetanum(j,2,i),j=1,3)
17652 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17653 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17654 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17655 !el        write (iout,*)
17656       enddo
17657 ! Check gamma gradient
17658       write (iout,*) &
17659        "Analytical (upper) and numerical (lower) gradient of gamma"
17660       do i=4,nres
17661         do j=1,3
17662           dcji=dc(j,i-3)
17663           dc(j,i-3)=dcji+aincr
17664           call chainbuild_cart
17665           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17666               dc(j,i-3)=dcji
17667           dcji=dc(j,i-2)
17668           dc(j,i-2)=dcji+aincr
17669           call chainbuild_cart
17670           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17671           dc(j,i-2)=dcji
17672           dcji=dc(j,i-1)
17673           dc(j,i-1)=dc(j,i-1)+aincr
17674           call chainbuild_cart
17675           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17676           dc(j,i-1)=dcji
17677         enddo
17678 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17679 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17680 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17681 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17682 !el        write (iout,'(5x,3(3f10.5,5x))') &
17683 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17684 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17685 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17686 !el        write (iout,*)
17687       enddo
17688 ! Check alpha gradient
17689       write (iout,*) &
17690        "Analytical (upper) and numerical (lower) gradient of alpha"
17691       do i=2,nres-1
17692        if(itype(i,1).ne.10) then
17693                  do j=1,3
17694                   dcji=dc(j,i-1)
17695                    dc(j,i-1)=dcji+aincr
17696               call chainbuild_cart
17697               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17698                  /aincr
17699                   dc(j,i-1)=dcji
17700               dcji=dc(j,i)
17701               dc(j,i)=dcji+aincr
17702               call chainbuild_cart
17703               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17704                  /aincr
17705               dc(j,i)=dcji
17706               dcji=dc(j,i+nres)
17707               dc(j,i+nres)=dc(j,i+nres)+aincr
17708               call chainbuild_cart
17709               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17710                  /aincr
17711              dc(j,i+nres)=dcji
17712             enddo
17713           endif
17714 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17715 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17716 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17717 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17718 !el        write (iout,'(5x,3(3f10.5,5x))') &
17719 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17720 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17721 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17722 !el        write (iout,*)
17723       enddo
17724 !     Check omega gradient
17725       write (iout,*) &
17726        "Analytical (upper) and numerical (lower) gradient of omega"
17727       do i=2,nres-1
17728        if(itype(i,1).ne.10) then
17729                  do j=1,3
17730                   dcji=dc(j,i-1)
17731                    dc(j,i-1)=dcji+aincr
17732               call chainbuild_cart
17733               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17734                  /aincr
17735                   dc(j,i-1)=dcji
17736               dcji=dc(j,i)
17737               dc(j,i)=dcji+aincr
17738               call chainbuild_cart
17739               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17740                  /aincr
17741               dc(j,i)=dcji
17742               dcji=dc(j,i+nres)
17743               dc(j,i+nres)=dc(j,i+nres)+aincr
17744               call chainbuild_cart
17745               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17746                  /aincr
17747              dc(j,i+nres)=dcji
17748             enddo
17749           endif
17750 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17751 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17752 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17753 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17754 !el        write (iout,'(5x,3(3f10.5,5x))') &
17755 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17756 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17757 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17758 !el        write (iout,*)
17759       enddo
17760       return
17761       end subroutine checkintcartgrad
17762 !-----------------------------------------------------------------------------
17763 ! q_measure.F
17764 !-----------------------------------------------------------------------------
17765       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17766 !      implicit real*8 (a-h,o-z)
17767 !      include 'DIMENSIONS'
17768 !      include 'COMMON.IOUNITS'
17769 !      include 'COMMON.CHAIN'
17770 !      include 'COMMON.INTERACT'
17771 !      include 'COMMON.VAR'
17772       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17773       integer :: kkk,nsep=3
17774       real(kind=8) :: qm      !dist,
17775       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17776       logical :: lprn=.false.
17777       logical :: flag
17778 !      real(kind=8) :: sigm,x
17779
17780 !el      sigm(x)=0.25d0*x     ! local function
17781       qqmax=1.0d10
17782       do kkk=1,nperm
17783       qq = 0.0d0
17784       nl=0
17785        if(flag) then
17786         do il=seg1+nsep,seg2
17787           do jl=seg1,il-nsep
17788             nl=nl+1
17789             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17790                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17791                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17792             dij=dist(il,jl)
17793             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17794             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17795               nl=nl+1
17796               d0ijCM=dsqrt( &
17797                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17798                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17799                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17800               dijCM=dist(il+nres,jl+nres)
17801               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17802             endif
17803             qq = qq+qqij+qqijCM
17804           enddo
17805         enddo
17806         qq = qq/nl
17807       else
17808       do il=seg1,seg2
17809         if((seg3-il).lt.3) then
17810              secseg=il+3
17811         else
17812              secseg=seg3
17813         endif
17814           do jl=secseg,seg4
17815             nl=nl+1
17816             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17817                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17818                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17819             dij=dist(il,jl)
17820             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17821             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17822               nl=nl+1
17823               d0ijCM=dsqrt( &
17824                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17825                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17826                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17827               dijCM=dist(il+nres,jl+nres)
17828               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17829             endif
17830             qq = qq+qqij+qqijCM
17831           enddo
17832         enddo
17833       qq = qq/nl
17834       endif
17835       if (qqmax.le.qq) qqmax=qq
17836       enddo
17837       qwolynes=1.0d0-qqmax
17838       return
17839       end function qwolynes
17840 !-----------------------------------------------------------------------------
17841       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17842 !      implicit real*8 (a-h,o-z)
17843 !      include 'DIMENSIONS'
17844 !      include 'COMMON.IOUNITS'
17845 !      include 'COMMON.CHAIN'
17846 !      include 'COMMON.INTERACT'
17847 !      include 'COMMON.VAR'
17848 !      include 'COMMON.MD'
17849       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17850       integer :: nsep=3, kkk
17851 !el      real(kind=8) :: dist
17852       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17853       logical :: lprn=.false.
17854       logical :: flag
17855       real(kind=8) :: sim,dd0,fac,ddqij
17856 !el      sigm(x)=0.25d0*x           ! local function
17857       do kkk=1,nperm
17858       do i=0,nres
17859         do j=1,3
17860           dqwol(j,i)=0.0d0
17861           dxqwol(j,i)=0.0d0
17862         enddo
17863       enddo
17864       nl=0
17865        if(flag) then
17866         do il=seg1+nsep,seg2
17867           do jl=seg1,il-nsep
17868             nl=nl+1
17869             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17870                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17871                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17872             dij=dist(il,jl)
17873             sim = 1.0d0/sigm(d0ij)
17874             sim = sim*sim
17875             dd0 = dij-d0ij
17876             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17877           do k=1,3
17878               ddqij = (c(k,il)-c(k,jl))*fac
17879               dqwol(k,il)=dqwol(k,il)+ddqij
17880               dqwol(k,jl)=dqwol(k,jl)-ddqij
17881             enddo
17882
17883             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17884               nl=nl+1
17885               d0ijCM=dsqrt( &
17886                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17887                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17888                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17889               dijCM=dist(il+nres,jl+nres)
17890               sim = 1.0d0/sigm(d0ijCM)
17891               sim = sim*sim
17892               dd0=dijCM-d0ijCM
17893               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17894               do k=1,3
17895                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17896                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17897                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17898               enddo
17899             endif
17900           enddo
17901         enddo
17902        else
17903         do il=seg1,seg2
17904         if((seg3-il).lt.3) then
17905              secseg=il+3
17906         else
17907              secseg=seg3
17908         endif
17909           do jl=secseg,seg4
17910             nl=nl+1
17911             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17912                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17913                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17914             dij=dist(il,jl)
17915             sim = 1.0d0/sigm(d0ij)
17916             sim = sim*sim
17917             dd0 = dij-d0ij
17918             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17919             do k=1,3
17920               ddqij = (c(k,il)-c(k,jl))*fac
17921               dqwol(k,il)=dqwol(k,il)+ddqij
17922               dqwol(k,jl)=dqwol(k,jl)-ddqij
17923             enddo
17924             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17925               nl=nl+1
17926               d0ijCM=dsqrt( &
17927                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17928                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17929                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17930               dijCM=dist(il+nres,jl+nres)
17931               sim = 1.0d0/sigm(d0ijCM)
17932               sim=sim*sim
17933               dd0 = dijCM-d0ijCM
17934               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17935               do k=1,3
17936                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17937                dxqwol(k,il)=dxqwol(k,il)+ddqij
17938                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17939               enddo
17940             endif
17941           enddo
17942         enddo
17943       endif
17944       enddo
17945        do i=0,nres
17946          do j=1,3
17947            dqwol(j,i)=dqwol(j,i)/nl
17948            dxqwol(j,i)=dxqwol(j,i)/nl
17949          enddo
17950        enddo
17951       return
17952       end subroutine qwolynes_prim
17953 !-----------------------------------------------------------------------------
17954       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17955 !      implicit real*8 (a-h,o-z)
17956 !      include 'DIMENSIONS'
17957 !      include 'COMMON.IOUNITS'
17958 !      include 'COMMON.CHAIN'
17959 !      include 'COMMON.INTERACT'
17960 !      include 'COMMON.VAR'
17961       integer :: seg1,seg2,seg3,seg4
17962       logical :: flag
17963       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17964       real(kind=8),dimension(3,0:2*nres) :: cdummy
17965       real(kind=8) :: q1,q2
17966       real(kind=8) :: delta=1.0d-10
17967       integer :: i,j
17968
17969       do i=0,nres
17970         do j=1,3
17971           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17972           cdummy(j,i)=c(j,i)
17973           c(j,i)=c(j,i)+delta
17974           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17975           qwolan(j,i)=(q2-q1)/delta
17976           c(j,i)=cdummy(j,i)
17977         enddo
17978       enddo
17979       do i=0,nres
17980         do j=1,3
17981           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17982           cdummy(j,i+nres)=c(j,i+nres)
17983           c(j,i+nres)=c(j,i+nres)+delta
17984           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17985           qwolxan(j,i)=(q2-q1)/delta
17986           c(j,i+nres)=cdummy(j,i+nres)
17987         enddo
17988       enddo
17989 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17990 !      do i=0,nct
17991 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17992 !      enddo
17993 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17994 !      do i=0,nct
17995 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17996 !      enddo
17997       return
17998       end subroutine qwol_num
17999 !-----------------------------------------------------------------------------
18000       subroutine EconstrQ
18001 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18002 !      implicit real*8 (a-h,o-z)
18003 !      include 'DIMENSIONS'
18004 !      include 'COMMON.CONTROL'
18005 !      include 'COMMON.VAR'
18006 !      include 'COMMON.MD'
18007       use MD_data
18008 !#ifndef LANG0
18009 !      include 'COMMON.LANGEVIN'
18010 !#else
18011 !      include 'COMMON.LANGEVIN.lang0'
18012 !#endif
18013 !      include 'COMMON.CHAIN'
18014 !      include 'COMMON.DERIV'
18015 !      include 'COMMON.GEO'
18016 !      include 'COMMON.LOCAL'
18017 !      include 'COMMON.INTERACT'
18018 !      include 'COMMON.IOUNITS'
18019 !      include 'COMMON.NAMES'
18020 !      include 'COMMON.TIME1'
18021       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18022       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18023                    duconst,duxconst
18024       integer :: kstart,kend,lstart,lend,idummy
18025       real(kind=8) :: delta=1.0d-7
18026       integer :: i,j,k,ii
18027       do i=0,nres
18028          do j=1,3
18029             duconst(j,i)=0.0d0
18030             dudconst(j,i)=0.0d0
18031             duxconst(j,i)=0.0d0
18032             dudxconst(j,i)=0.0d0
18033          enddo
18034       enddo
18035       Uconst=0.0d0
18036       do i=1,nfrag
18037          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18038            idummy,idummy)
18039          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18040 ! Calculating the derivatives of Constraint energy with respect to Q
18041          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18042            qinfrag(i,iset))
18043 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18044 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18045 !         hmnum=(hm2-hm1)/delta
18046 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18047 !     &   qinfrag(i,iset))
18048 !         write(iout,*) "harmonicnum frag", hmnum
18049 ! Calculating the derivatives of Q with respect to cartesian coordinates
18050          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18051           idummy,idummy)
18052 !         write(iout,*) "dqwol "
18053 !         do ii=1,nres
18054 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18055 !         enddo
18056 !         write(iout,*) "dxqwol "
18057 !         do ii=1,nres
18058 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18059 !         enddo
18060 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18061 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18062 !     &  ,idummy,idummy)
18063 !  The gradients of Uconst in Cs
18064          do ii=0,nres
18065             do j=1,3
18066                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18067                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18068             enddo
18069          enddo
18070       enddo
18071       do i=1,npair
18072          kstart=ifrag(1,ipair(1,i,iset),iset)
18073          kend=ifrag(2,ipair(1,i,iset),iset)
18074          lstart=ifrag(1,ipair(2,i,iset),iset)
18075          lend=ifrag(2,ipair(2,i,iset),iset)
18076          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18077          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18078 !  Calculating dU/dQ
18079          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18080 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18081 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18082 !         hmnum=(hm2-hm1)/delta
18083 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18084 !     &   qinpair(i,iset))
18085 !         write(iout,*) "harmonicnum pair ", hmnum
18086 ! Calculating dQ/dXi
18087          call qwolynes_prim(kstart,kend,.false.,&
18088           lstart,lend)
18089 !         write(iout,*) "dqwol "
18090 !         do ii=1,nres
18091 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18092 !         enddo
18093 !         write(iout,*) "dxqwol "
18094 !         do ii=1,nres
18095 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18096 !        enddo
18097 ! Calculating numerical gradients
18098 !        call qwol_num(kstart,kend,.false.
18099 !     &  ,lstart,lend)
18100 ! The gradients of Uconst in Cs
18101          do ii=0,nres
18102             do j=1,3
18103                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18104                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18105             enddo
18106          enddo
18107       enddo
18108 !      write(iout,*) "Uconst inside subroutine ", Uconst
18109 ! Transforming the gradients from Cs to dCs for the backbone
18110       do i=0,nres
18111          do j=i+1,nres
18112            do k=1,3
18113              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18114            enddo
18115          enddo
18116       enddo
18117 !  Transforming the gradients from Cs to dCs for the side chains
18118       do i=1,nres
18119          do j=1,3
18120            dudxconst(j,i)=duxconst(j,i)
18121          enddo
18122       enddo
18123 !      write(iout,*) "dU/ddc backbone "
18124 !       do ii=0,nres
18125 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18126 !      enddo
18127 !      write(iout,*) "dU/ddX side chain "
18128 !      do ii=1,nres
18129 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18130 !      enddo
18131 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18132 !      call dEconstrQ_num
18133       return
18134       end subroutine EconstrQ
18135 !-----------------------------------------------------------------------------
18136       subroutine dEconstrQ_num
18137 ! Calculating numerical dUconst/ddc and dUconst/ddx
18138 !      implicit real*8 (a-h,o-z)
18139 !      include 'DIMENSIONS'
18140 !      include 'COMMON.CONTROL'
18141 !      include 'COMMON.VAR'
18142 !      include 'COMMON.MD'
18143       use MD_data
18144 !#ifndef LANG0
18145 !      include 'COMMON.LANGEVIN'
18146 !#else
18147 !      include 'COMMON.LANGEVIN.lang0'
18148 !#endif
18149 !      include 'COMMON.CHAIN'
18150 !      include 'COMMON.DERIV'
18151 !      include 'COMMON.GEO'
18152 !      include 'COMMON.LOCAL'
18153 !      include 'COMMON.INTERACT'
18154 !      include 'COMMON.IOUNITS'
18155 !      include 'COMMON.NAMES'
18156 !      include 'COMMON.TIME1'
18157       real(kind=8) :: uzap1,uzap2
18158       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18159       integer :: kstart,kend,lstart,lend,idummy
18160       real(kind=8) :: delta=1.0d-7
18161 !el local variables
18162       integer :: i,ii,j
18163 !     real(kind=8) ::
18164 !     For the backbone
18165       do i=0,nres-1
18166          do j=1,3
18167             dUcartan(j,i)=0.0d0
18168             cdummy(j,i)=dc(j,i)
18169             dc(j,i)=dc(j,i)+delta
18170             call chainbuild_cart
18171           uzap2=0.0d0
18172             do ii=1,nfrag
18173              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18174                 idummy,idummy)
18175                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18176                 qinfrag(ii,iset))
18177             enddo
18178             do ii=1,npair
18179                kstart=ifrag(1,ipair(1,ii,iset),iset)
18180                kend=ifrag(2,ipair(1,ii,iset),iset)
18181                lstart=ifrag(1,ipair(2,ii,iset),iset)
18182                lend=ifrag(2,ipair(2,ii,iset),iset)
18183                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18184                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18185                  qinpair(ii,iset))
18186             enddo
18187             dc(j,i)=cdummy(j,i)
18188             call chainbuild_cart
18189             uzap1=0.0d0
18190              do ii=1,nfrag
18191              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18192                 idummy,idummy)
18193                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18194                 qinfrag(ii,iset))
18195             enddo
18196             do ii=1,npair
18197                kstart=ifrag(1,ipair(1,ii,iset),iset)
18198                kend=ifrag(2,ipair(1,ii,iset),iset)
18199                lstart=ifrag(1,ipair(2,ii,iset),iset)
18200                lend=ifrag(2,ipair(2,ii,iset),iset)
18201                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18202                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18203                 qinpair(ii,iset))
18204             enddo
18205             ducartan(j,i)=(uzap2-uzap1)/(delta)
18206          enddo
18207       enddo
18208 ! Calculating numerical gradients for dU/ddx
18209       do i=0,nres-1
18210          duxcartan(j,i)=0.0d0
18211          do j=1,3
18212             cdummy(j,i)=dc(j,i+nres)
18213             dc(j,i+nres)=dc(j,i+nres)+delta
18214             call chainbuild_cart
18215           uzap2=0.0d0
18216             do ii=1,nfrag
18217              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18218                 idummy,idummy)
18219                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18220                 qinfrag(ii,iset))
18221             enddo
18222             do ii=1,npair
18223                kstart=ifrag(1,ipair(1,ii,iset),iset)
18224                kend=ifrag(2,ipair(1,ii,iset),iset)
18225                lstart=ifrag(1,ipair(2,ii,iset),iset)
18226                lend=ifrag(2,ipair(2,ii,iset),iset)
18227                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18228                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18229                 qinpair(ii,iset))
18230             enddo
18231             dc(j,i+nres)=cdummy(j,i)
18232             call chainbuild_cart
18233             uzap1=0.0d0
18234              do ii=1,nfrag
18235                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18236                 ifrag(2,ii,iset),.true.,idummy,idummy)
18237                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18238                 qinfrag(ii,iset))
18239             enddo
18240             do ii=1,npair
18241                kstart=ifrag(1,ipair(1,ii,iset),iset)
18242                kend=ifrag(2,ipair(1,ii,iset),iset)
18243                lstart=ifrag(1,ipair(2,ii,iset),iset)
18244                lend=ifrag(2,ipair(2,ii,iset),iset)
18245                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18246                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18247                 qinpair(ii,iset))
18248             enddo
18249             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18250          enddo
18251       enddo
18252       write(iout,*) "Numerical dUconst/ddc backbone "
18253       do ii=0,nres
18254         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18255       enddo
18256 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18257 !      do ii=1,nres
18258 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18259 !      enddo
18260       return
18261       end subroutine dEconstrQ_num
18262 !-----------------------------------------------------------------------------
18263 ! ssMD.F
18264 !-----------------------------------------------------------------------------
18265       subroutine check_energies
18266
18267 !      use random, only: ran_number
18268
18269 !      implicit none
18270 !     Includes
18271 !      include 'DIMENSIONS'
18272 !      include 'COMMON.CHAIN'
18273 !      include 'COMMON.VAR'
18274 !      include 'COMMON.IOUNITS'
18275 !      include 'COMMON.SBRIDGE'
18276 !      include 'COMMON.LOCAL'
18277 !      include 'COMMON.GEO'
18278
18279 !     External functions
18280 !EL      double precision ran_number
18281 !EL      external ran_number
18282
18283 !     Local variables
18284       integer :: i,j,k,l,lmax,p,pmax
18285       real(kind=8) :: rmin,rmax
18286       real(kind=8) :: eij
18287
18288       real(kind=8) :: d
18289       real(kind=8) :: wi,rij,tj,pj
18290 !      return
18291
18292       i=5
18293       j=14
18294
18295       d=dsc(1)
18296       rmin=2.0D0
18297       rmax=12.0D0
18298
18299       lmax=10000
18300       pmax=1
18301
18302       do k=1,3
18303         c(k,i)=0.0D0
18304         c(k,j)=0.0D0
18305         c(k,nres+i)=0.0D0
18306         c(k,nres+j)=0.0D0
18307       enddo
18308
18309       do l=1,lmax
18310
18311 !t        wi=ran_number(0.0D0,pi)
18312 !        wi=ran_number(0.0D0,pi/6.0D0)
18313 !        wi=0.0D0
18314 !t        tj=ran_number(0.0D0,pi)
18315 !t        pj=ran_number(0.0D0,pi)
18316 !        pj=ran_number(0.0D0,pi/6.0D0)
18317 !        pj=0.0D0
18318
18319         do p=1,pmax
18320 !t           rij=ran_number(rmin,rmax)
18321
18322            c(1,j)=d*sin(pj)*cos(tj)
18323            c(2,j)=d*sin(pj)*sin(tj)
18324            c(3,j)=d*cos(pj)
18325
18326            c(3,nres+i)=-rij
18327
18328            c(1,i)=d*sin(wi)
18329            c(3,i)=-rij-d*cos(wi)
18330
18331            do k=1,3
18332               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18333               dc_norm(k,nres+i)=dc(k,nres+i)/d
18334               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18335               dc_norm(k,nres+j)=dc(k,nres+j)/d
18336            enddo
18337
18338            call dyn_ssbond_ene(i,j,eij)
18339         enddo
18340       enddo
18341       call exit(1)
18342       return
18343       end subroutine check_energies
18344 !-----------------------------------------------------------------------------
18345       subroutine dyn_ssbond_ene(resi,resj,eij)
18346 !      implicit none
18347 !      Includes
18348       use calc_data
18349       use comm_sschecks
18350 !      include 'DIMENSIONS'
18351 !      include 'COMMON.SBRIDGE'
18352 !      include 'COMMON.CHAIN'
18353 !      include 'COMMON.DERIV'
18354 !      include 'COMMON.LOCAL'
18355 !      include 'COMMON.INTERACT'
18356 !      include 'COMMON.VAR'
18357 !      include 'COMMON.IOUNITS'
18358 !      include 'COMMON.CALC'
18359 #ifndef CLUST
18360 #ifndef WHAM
18361        use MD_data
18362 !      include 'COMMON.MD'
18363 !      use MD, only: totT,t_bath
18364 #endif
18365 #endif
18366 !     External functions
18367 !EL      double precision h_base
18368 !EL      external h_base
18369
18370 !     Input arguments
18371       integer :: resi,resj
18372
18373 !     Output arguments
18374       real(kind=8) :: eij
18375
18376 !     Local variables
18377       logical :: havebond
18378       integer itypi,itypj
18379       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18380       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18381       real(kind=8),dimension(3) :: dcosom1,dcosom2
18382       real(kind=8) :: ed
18383       real(kind=8) :: pom1,pom2
18384       real(kind=8) :: ljA,ljB,ljXs
18385       real(kind=8),dimension(1:3) :: d_ljB
18386       real(kind=8) :: ssA,ssB,ssC,ssXs
18387       real(kind=8) :: ssxm,ljxm,ssm,ljm
18388       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18389       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18390       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18391 !-------FIRST METHOD
18392       real(kind=8) :: xm
18393       real(kind=8),dimension(1:3) :: d_xm
18394 !-------END FIRST METHOD
18395 !-------SECOND METHOD
18396 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18397 !-------END SECOND METHOD
18398
18399 !-------TESTING CODE
18400 !el      logical :: checkstop,transgrad
18401 !el      common /sschecks/ checkstop,transgrad
18402
18403       integer :: icheck,nicheck,jcheck,njcheck
18404       real(kind=8),dimension(-1:1) :: echeck
18405       real(kind=8) :: deps,ssx0,ljx0
18406 !-------END TESTING CODE
18407
18408       eij=0.0d0
18409       i=resi
18410       j=resj
18411
18412 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18413 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18414
18415       itypi=itype(i,1)
18416       dxi=dc_norm(1,nres+i)
18417       dyi=dc_norm(2,nres+i)
18418       dzi=dc_norm(3,nres+i)
18419       dsci_inv=vbld_inv(i+nres)
18420
18421       itypj=itype(j,1)
18422       xj=c(1,nres+j)-c(1,nres+i)
18423       yj=c(2,nres+j)-c(2,nres+i)
18424       zj=c(3,nres+j)-c(3,nres+i)
18425       dxj=dc_norm(1,nres+j)
18426       dyj=dc_norm(2,nres+j)
18427       dzj=dc_norm(3,nres+j)
18428       dscj_inv=vbld_inv(j+nres)
18429
18430       chi1=chi(itypi,itypj)
18431       chi2=chi(itypj,itypi)
18432       chi12=chi1*chi2
18433       chip1=chip(itypi)
18434       chip2=chip(itypj)
18435       chip12=chip1*chip2
18436       alf1=alp(itypi)
18437       alf2=alp(itypj)
18438       alf12=0.5D0*(alf1+alf2)
18439
18440       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18441       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18442 !     The following are set in sc_angular
18443 !      erij(1)=xj*rij
18444 !      erij(2)=yj*rij
18445 !      erij(3)=zj*rij
18446 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18447 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18448 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18449       call sc_angular
18450       rij=1.0D0/rij  ! Reset this so it makes sense
18451
18452       sig0ij=sigma(itypi,itypj)
18453       sig=sig0ij*dsqrt(1.0D0/sigsq)
18454
18455       ljXs=sig-sig0ij
18456       ljA=eps1*eps2rt**2*eps3rt**2
18457       ljB=ljA*bb_aq(itypi,itypj)
18458       ljA=ljA*aa_aq(itypi,itypj)
18459       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18460
18461       ssXs=d0cm
18462       deltat1=1.0d0-om1
18463       deltat2=1.0d0+om2
18464       deltat12=om2-om1+2.0d0
18465       cosphi=om12-om1*om2
18466       ssA=akcm
18467       ssB=akct*deltat12
18468       ssC=ss_depth &
18469            +akth*(deltat1*deltat1+deltat2*deltat2) &
18470            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18471       ssxm=ssXs-0.5D0*ssB/ssA
18472
18473 !-------TESTING CODE
18474 !$$$c     Some extra output
18475 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18476 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18477 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18478 !$$$      if (ssx0.gt.0.0d0) then
18479 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18480 !$$$      else
18481 !$$$        ssx0=ssxm
18482 !$$$      endif
18483 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18484 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18485 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18486 !$$$      return
18487 !-------END TESTING CODE
18488
18489 !-------TESTING CODE
18490 !     Stop and plot energy and derivative as a function of distance
18491       if (checkstop) then
18492         ssm=ssC-0.25D0*ssB*ssB/ssA
18493         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18494         if (ssm.lt.ljm .and. &
18495              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18496           nicheck=1000
18497           njcheck=1
18498           deps=0.5d-7
18499         else
18500           checkstop=.false.
18501         endif
18502       endif
18503       if (.not.checkstop) then
18504         nicheck=0
18505         njcheck=-1
18506       endif
18507
18508       do icheck=0,nicheck
18509       do jcheck=-1,njcheck
18510       if (checkstop) rij=(ssxm-1.0d0)+ &
18511              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18512 !-------END TESTING CODE
18513
18514       if (rij.gt.ljxm) then
18515         havebond=.false.
18516         ljd=rij-ljXs
18517         fac=(1.0D0/ljd)**expon
18518         e1=fac*fac*aa_aq(itypi,itypj)
18519         e2=fac*bb_aq(itypi,itypj)
18520         eij=eps1*eps2rt*eps3rt*(e1+e2)
18521         eps2der=eij*eps3rt
18522         eps3der=eij*eps2rt
18523         eij=eij*eps2rt*eps3rt
18524
18525         sigder=-sig/sigsq
18526         e1=e1*eps1*eps2rt**2*eps3rt**2
18527         ed=-expon*(e1+eij)/ljd
18528         sigder=ed*sigder
18529         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18530         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18531         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18532              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18533       else if (rij.lt.ssxm) then
18534         havebond=.true.
18535         ssd=rij-ssXs
18536         eij=ssA*ssd*ssd+ssB*ssd+ssC
18537
18538         ed=2*akcm*ssd+akct*deltat12
18539         pom1=akct*ssd
18540         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18541         eom1=-2*akth*deltat1-pom1-om2*pom2
18542         eom2= 2*akth*deltat2+pom1-om1*pom2
18543         eom12=pom2
18544       else
18545         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18546
18547         d_ssxm(1)=0.5D0*akct/ssA
18548         d_ssxm(2)=-d_ssxm(1)
18549         d_ssxm(3)=0.0D0
18550
18551         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18552         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18553         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18554         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18555
18556 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18557         xm=0.5d0*(ssxm+ljxm)
18558         do k=1,3
18559           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18560         enddo
18561         if (rij.lt.xm) then
18562           havebond=.true.
18563           ssm=ssC-0.25D0*ssB*ssB/ssA
18564           d_ssm(1)=0.5D0*akct*ssB/ssA
18565           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18566           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18567           d_ssm(3)=omega
18568           f1=(rij-xm)/(ssxm-xm)
18569           f2=(rij-ssxm)/(xm-ssxm)
18570           h1=h_base(f1,hd1)
18571           h2=h_base(f2,hd2)
18572           eij=ssm*h1+Ht*h2
18573           delta_inv=1.0d0/(xm-ssxm)
18574           deltasq_inv=delta_inv*delta_inv
18575           fac=ssm*hd1-Ht*hd2
18576           fac1=deltasq_inv*fac*(xm-rij)
18577           fac2=deltasq_inv*fac*(rij-ssxm)
18578           ed=delta_inv*(Ht*hd2-ssm*hd1)
18579           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18580           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18581           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18582         else
18583           havebond=.false.
18584           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18585           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18586           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18587           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18588                alf12/eps3rt)
18589           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18590           f1=(rij-ljxm)/(xm-ljxm)
18591           f2=(rij-xm)/(ljxm-xm)
18592           h1=h_base(f1,hd1)
18593           h2=h_base(f2,hd2)
18594           eij=Ht*h1+ljm*h2
18595           delta_inv=1.0d0/(ljxm-xm)
18596           deltasq_inv=delta_inv*delta_inv
18597           fac=Ht*hd1-ljm*hd2
18598           fac1=deltasq_inv*fac*(ljxm-rij)
18599           fac2=deltasq_inv*fac*(rij-xm)
18600           ed=delta_inv*(ljm*hd2-Ht*hd1)
18601           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18602           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18603           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18604         endif
18605 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18606
18607 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18608 !$$$        ssd=rij-ssXs
18609 !$$$        ljd=rij-ljXs
18610 !$$$        fac1=rij-ljxm
18611 !$$$        fac2=rij-ssxm
18612 !$$$
18613 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18614 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18615 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18616 !$$$
18617 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18618 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18619 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18620 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18621 !$$$        d_ssm(3)=omega
18622 !$$$
18623 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18624 !$$$        do k=1,3
18625 !$$$          d_ljm(k)=ljm*d_ljB(k)
18626 !$$$        enddo
18627 !$$$        ljm=ljm*ljB
18628 !$$$
18629 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18630 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18631 !$$$        d_ss(2)=akct*ssd
18632 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18633 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18634 !$$$        d_ss(3)=omega
18635 !$$$
18636 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18637 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18638 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18639 !$$$        do k=1,3
18640 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18641 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18642 !$$$        enddo
18643 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18644 !$$$
18645 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18646 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18647 !$$$        h1=h_base(f1,hd1)
18648 !$$$        h2=h_base(f2,hd2)
18649 !$$$        eij=ss*h1+ljf*h2
18650 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18651 !$$$        deltasq_inv=delta_inv*delta_inv
18652 !$$$        fac=ljf*hd2-ss*hd1
18653 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18654 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18655 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18656 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18657 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18658 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18659 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18660 !$$$
18661 !$$$        havebond=.false.
18662 !$$$        if (ed.gt.0.0d0) havebond=.true.
18663 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18664
18665       endif
18666
18667       if (havebond) then
18668 !#ifndef CLUST
18669 !#ifndef WHAM
18670 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18671 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18672 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18673 !        endif
18674 !#endif
18675 !#endif
18676         dyn_ssbond_ij(i,j)=eij
18677       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18678         dyn_ssbond_ij(i,j)=1.0d300
18679 !#ifndef CLUST
18680 !#ifndef WHAM
18681 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18682 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18683 !#endif
18684 !#endif
18685       endif
18686
18687 !-------TESTING CODE
18688 !el      if (checkstop) then
18689         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18690              "CHECKSTOP",rij,eij,ed
18691         echeck(jcheck)=eij
18692 !el      endif
18693       enddo
18694       if (checkstop) then
18695         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18696       endif
18697       enddo
18698       if (checkstop) then
18699         transgrad=.true.
18700         checkstop=.false.
18701       endif
18702 !-------END TESTING CODE
18703
18704       do k=1,3
18705         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18706         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18707       enddo
18708       do k=1,3
18709         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18710       enddo
18711       do k=1,3
18712         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18713              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18714              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18715         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18716              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18717              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18718       enddo
18719 !grad      do k=i,j-1
18720 !grad        do l=1,3
18721 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18722 !grad        enddo
18723 !grad      enddo
18724
18725       do l=1,3
18726         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18727         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18728       enddo
18729
18730       return
18731       end subroutine dyn_ssbond_ene
18732 !--------------------------------------------------------------------------
18733          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18734 !      implicit none
18735 !      Includes
18736       use calc_data
18737       use comm_sschecks
18738 !      include 'DIMENSIONS'
18739 !      include 'COMMON.SBRIDGE'
18740 !      include 'COMMON.CHAIN'
18741 !      include 'COMMON.DERIV'
18742 !      include 'COMMON.LOCAL'
18743 !      include 'COMMON.INTERACT'
18744 !      include 'COMMON.VAR'
18745 !      include 'COMMON.IOUNITS'
18746 !      include 'COMMON.CALC'
18747 #ifndef CLUST
18748 #ifndef WHAM
18749        use MD_data
18750 !      include 'COMMON.MD'
18751 !      use MD, only: totT,t_bath
18752 #endif
18753 #endif
18754       double precision h_base
18755       external h_base
18756
18757 !c     Input arguments
18758       integer resi,resj,resk,m,itypi,itypj,itypk
18759
18760 !c     Output arguments
18761       double precision eij,eij1,eij2,eij3
18762
18763 !c     Local variables
18764       logical havebond
18765 !c      integer itypi,itypj,k,l
18766       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18767       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18768       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18769       double precision sig0ij,ljd,sig,fac,e1,e2
18770       double precision dcosom1(3),dcosom2(3),ed
18771       double precision pom1,pom2
18772       double precision ljA,ljB,ljXs
18773       double precision d_ljB(1:3)
18774       double precision ssA,ssB,ssC,ssXs
18775       double precision ssxm,ljxm,ssm,ljm
18776       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18777       eij=0.0
18778       if (dtriss.eq.0) return
18779       i=resi
18780       j=resj
18781       k=resk
18782 !C      write(iout,*) resi,resj,resk
18783       itypi=itype(i,1)
18784       dxi=dc_norm(1,nres+i)
18785       dyi=dc_norm(2,nres+i)
18786       dzi=dc_norm(3,nres+i)
18787       dsci_inv=vbld_inv(i+nres)
18788       xi=c(1,nres+i)
18789       yi=c(2,nres+i)
18790       zi=c(3,nres+i)
18791       itypj=itype(j,1)
18792       xj=c(1,nres+j)
18793       yj=c(2,nres+j)
18794       zj=c(3,nres+j)
18795
18796       dxj=dc_norm(1,nres+j)
18797       dyj=dc_norm(2,nres+j)
18798       dzj=dc_norm(3,nres+j)
18799       dscj_inv=vbld_inv(j+nres)
18800       itypk=itype(k,1)
18801       xk=c(1,nres+k)
18802       yk=c(2,nres+k)
18803       zk=c(3,nres+k)
18804
18805       dxk=dc_norm(1,nres+k)
18806       dyk=dc_norm(2,nres+k)
18807       dzk=dc_norm(3,nres+k)
18808       dscj_inv=vbld_inv(k+nres)
18809       xij=xj-xi
18810       xik=xk-xi
18811       xjk=xk-xj
18812       yij=yj-yi
18813       yik=yk-yi
18814       yjk=yk-yj
18815       zij=zj-zi
18816       zik=zk-zi
18817       zjk=zk-zj
18818       rrij=(xij*xij+yij*yij+zij*zij)
18819       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18820       rrik=(xik*xik+yik*yik+zik*zik)
18821       rik=dsqrt(rrik)
18822       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18823       rjk=dsqrt(rrjk)
18824 !C there are three combination of distances for each trisulfide bonds
18825 !C The first case the ith atom is the center
18826 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18827 !C distance y is second distance the a,b,c,d are parameters derived for
18828 !C this problem d parameter was set as a penalty currenlty set to 1.
18829       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18830       eij1=0.0d0
18831       else
18832       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18833       endif
18834 !C second case jth atom is center
18835       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18836       eij2=0.0d0
18837       else
18838       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18839       endif
18840 !C the third case kth atom is the center
18841       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18842       eij3=0.0d0
18843       else
18844       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18845       endif
18846 !C      eij2=0.0
18847 !C      eij3=0.0
18848 !C      eij1=0.0
18849       eij=eij1+eij2+eij3
18850 !C      write(iout,*)i,j,k,eij
18851 !C The energy penalty calculated now time for the gradient part
18852 !C derivative over rij
18853       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18854       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18855             gg(1)=xij*fac/rij
18856             gg(2)=yij*fac/rij
18857             gg(3)=zij*fac/rij
18858       do m=1,3
18859         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18860         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18861       enddo
18862
18863       do l=1,3
18864         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18865         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18866       enddo
18867 !C now derivative over rik
18868       fac=-eij1**2/dtriss* &
18869       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18870       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18871             gg(1)=xik*fac/rik
18872             gg(2)=yik*fac/rik
18873             gg(3)=zik*fac/rik
18874       do m=1,3
18875         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18876         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18877       enddo
18878       do l=1,3
18879         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18880         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18881       enddo
18882 !C now derivative over rjk
18883       fac=-eij2**2/dtriss* &
18884       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18885       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18886             gg(1)=xjk*fac/rjk
18887             gg(2)=yjk*fac/rjk
18888             gg(3)=zjk*fac/rjk
18889       do m=1,3
18890         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18891         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18892       enddo
18893       do l=1,3
18894         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18895         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18896       enddo
18897       return
18898       end subroutine triple_ssbond_ene
18899
18900
18901
18902 !-----------------------------------------------------------------------------
18903       real(kind=8) function h_base(x,deriv)
18904 !     A smooth function going 0->1 in range [0,1]
18905 !     It should NOT be called outside range [0,1], it will not work there.
18906       implicit none
18907
18908 !     Input arguments
18909       real(kind=8) :: x
18910
18911 !     Output arguments
18912       real(kind=8) :: deriv
18913
18914 !     Local variables
18915       real(kind=8) :: xsq
18916
18917
18918 !     Two parabolas put together.  First derivative zero at extrema
18919 !$$$      if (x.lt.0.5D0) then
18920 !$$$        h_base=2.0D0*x*x
18921 !$$$        deriv=4.0D0*x
18922 !$$$      else
18923 !$$$        deriv=1.0D0-x
18924 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18925 !$$$        deriv=4.0D0*deriv
18926 !$$$      endif
18927
18928 !     Third degree polynomial.  First derivative zero at extrema
18929       h_base=x*x*(3.0d0-2.0d0*x)
18930       deriv=6.0d0*x*(1.0d0-x)
18931
18932 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18933 !$$$      xsq=x*x
18934 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18935 !$$$      deriv=x-1.0d0
18936 !$$$      deriv=deriv*deriv
18937 !$$$      deriv=30.0d0*xsq*deriv
18938
18939       return
18940       end function h_base
18941 !-----------------------------------------------------------------------------
18942       subroutine dyn_set_nss
18943 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18944 !      implicit none
18945       use MD_data, only: totT,t_bath
18946 !     Includes
18947 !      include 'DIMENSIONS'
18948 #ifdef MPI
18949       include "mpif.h"
18950 #endif
18951 !      include 'COMMON.SBRIDGE'
18952 !      include 'COMMON.CHAIN'
18953 !      include 'COMMON.IOUNITS'
18954 !      include 'COMMON.SETUP'
18955 !      include 'COMMON.MD'
18956 !     Local variables
18957       real(kind=8) :: emin
18958       integer :: i,j,imin,ierr
18959       integer :: diff,allnss,newnss
18960       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18961                 newihpb,newjhpb
18962       logical :: found
18963       integer,dimension(0:nfgtasks) :: i_newnss
18964       integer,dimension(0:nfgtasks) :: displ
18965       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18966       integer :: g_newnss
18967
18968       allnss=0
18969       do i=1,nres-1
18970         do j=i+1,nres
18971           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18972             allnss=allnss+1
18973             allflag(allnss)=0
18974             allihpb(allnss)=i
18975             alljhpb(allnss)=j
18976           endif
18977         enddo
18978       enddo
18979
18980 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18981
18982  1    emin=1.0d300
18983       do i=1,allnss
18984         if (allflag(i).eq.0 .and. &
18985              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18986           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18987           imin=i
18988         endif
18989       enddo
18990       if (emin.lt.1.0d300) then
18991         allflag(imin)=1
18992         do i=1,allnss
18993           if (allflag(i).eq.0 .and. &
18994                (allihpb(i).eq.allihpb(imin) .or. &
18995                alljhpb(i).eq.allihpb(imin) .or. &
18996                allihpb(i).eq.alljhpb(imin) .or. &
18997                alljhpb(i).eq.alljhpb(imin))) then
18998             allflag(i)=-1
18999           endif
19000         enddo
19001         goto 1
19002       endif
19003
19004 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19005
19006       newnss=0
19007       do i=1,allnss
19008         if (allflag(i).eq.1) then
19009           newnss=newnss+1
19010           newihpb(newnss)=allihpb(i)
19011           newjhpb(newnss)=alljhpb(i)
19012         endif
19013       enddo
19014
19015 #ifdef MPI
19016       if (nfgtasks.gt.1)then
19017
19018         call MPI_Reduce(newnss,g_newnss,1,&
19019           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19020         call MPI_Gather(newnss,1,MPI_INTEGER,&
19021                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19022         displ(0)=0
19023         do i=1,nfgtasks-1,1
19024           displ(i)=i_newnss(i-1)+displ(i-1)
19025         enddo
19026         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19027                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19028                          king,FG_COMM,IERR)
19029         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19030                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19031                          king,FG_COMM,IERR)
19032         if(fg_rank.eq.0) then
19033 !         print *,'g_newnss',g_newnss
19034 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19035 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19036          newnss=g_newnss
19037          do i=1,newnss
19038           newihpb(i)=g_newihpb(i)
19039           newjhpb(i)=g_newjhpb(i)
19040          enddo
19041         endif
19042       endif
19043 #endif
19044
19045       diff=newnss-nss
19046
19047 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19048 !       print *,newnss,nss,maxdim
19049       do i=1,nss
19050         found=.false.
19051 !        print *,newnss
19052         do j=1,newnss
19053 !!          print *,j
19054           if (idssb(i).eq.newihpb(j) .and. &
19055                jdssb(i).eq.newjhpb(j)) found=.true.
19056         enddo
19057 #ifndef CLUST
19058 #ifndef WHAM
19059 !        write(iout,*) "found",found,i,j
19060         if (.not.found.and.fg_rank.eq.0) &
19061             write(iout,'(a15,f12.2,f8.1,2i5)') &
19062              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19063 #endif
19064 #endif
19065       enddo
19066
19067       do i=1,newnss
19068         found=.false.
19069         do j=1,nss
19070 !          print *,i,j
19071           if (newihpb(i).eq.idssb(j) .and. &
19072                newjhpb(i).eq.jdssb(j)) found=.true.
19073         enddo
19074 #ifndef CLUST
19075 #ifndef WHAM
19076 !        write(iout,*) "found",found,i,j
19077         if (.not.found.and.fg_rank.eq.0) &
19078             write(iout,'(a15,f12.2,f8.1,2i5)') &
19079              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19080 #endif
19081 #endif
19082       enddo
19083
19084       nss=newnss
19085       do i=1,nss
19086         idssb(i)=newihpb(i)
19087         jdssb(i)=newjhpb(i)
19088       enddo
19089
19090       return
19091       end subroutine dyn_set_nss
19092 ! Lipid transfer energy function
19093       subroutine Eliptransfer(eliptran)
19094 !C this is done by Adasko
19095 !C      print *,"wchodze"
19096 !C structure of box:
19097 !C      water
19098 !C--bordliptop-- buffore starts
19099 !C--bufliptop--- here true lipid starts
19100 !C      lipid
19101 !C--buflipbot--- lipid ends buffore starts
19102 !C--bordlipbot--buffore ends
19103       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19104       integer :: i
19105       eliptran=0.0
19106 !      print *, "I am in eliptran"
19107       do i=ilip_start,ilip_end
19108 !C       do i=1,1
19109         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19110          cycle
19111
19112         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19113         if (positi.le.0.0) positi=positi+boxzsize
19114 !C        print *,i
19115 !C first for peptide groups
19116 !c for each residue check if it is in lipid or lipid water border area
19117        if ((positi.gt.bordlipbot)  &
19118       .and.(positi.lt.bordliptop)) then
19119 !C the energy transfer exist
19120         if (positi.lt.buflipbot) then
19121 !C what fraction I am in
19122          fracinbuf=1.0d0-      &
19123              ((positi-bordlipbot)/lipbufthick)
19124 !C lipbufthick is thickenes of lipid buffore
19125          sslip=sscalelip(fracinbuf)
19126          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19127          eliptran=eliptran+sslip*pepliptran
19128          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19129          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19130 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19131
19132 !C        print *,"doing sccale for lower part"
19133 !C         print *,i,sslip,fracinbuf,ssgradlip
19134         elseif (positi.gt.bufliptop) then
19135          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19136          sslip=sscalelip(fracinbuf)
19137          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19138          eliptran=eliptran+sslip*pepliptran
19139          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19140          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19141 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19142 !C          print *, "doing sscalefor top part"
19143 !C         print *,i,sslip,fracinbuf,ssgradlip
19144         else
19145          eliptran=eliptran+pepliptran
19146 !C         print *,"I am in true lipid"
19147         endif
19148 !C       else
19149 !C       eliptran=elpitran+0.0 ! I am in water
19150        endif
19151        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19152        enddo
19153 ! here starts the side chain transfer
19154        do i=ilip_start,ilip_end
19155         if (itype(i,1).eq.ntyp1) cycle
19156         positi=(mod(c(3,i+nres),boxzsize))
19157         if (positi.le.0) positi=positi+boxzsize
19158 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19159 !c for each residue check if it is in lipid or lipid water border area
19160 !C       respos=mod(c(3,i+nres),boxzsize)
19161 !C       print *,positi,bordlipbot,buflipbot
19162        if ((positi.gt.bordlipbot) &
19163        .and.(positi.lt.bordliptop)) then
19164 !C the energy transfer exist
19165         if (positi.lt.buflipbot) then
19166          fracinbuf=1.0d0-   &
19167            ((positi-bordlipbot)/lipbufthick)
19168 !C lipbufthick is thickenes of lipid buffore
19169          sslip=sscalelip(fracinbuf)
19170          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19171          eliptran=eliptran+sslip*liptranene(itype(i,1))
19172          gliptranx(3,i)=gliptranx(3,i) &
19173       +ssgradlip*liptranene(itype(i,1))
19174          gliptranc(3,i-1)= gliptranc(3,i-1) &
19175       +ssgradlip*liptranene(itype(i,1))
19176 !C         print *,"doing sccale for lower part"
19177         elseif (positi.gt.bufliptop) then
19178          fracinbuf=1.0d0-  &
19179       ((bordliptop-positi)/lipbufthick)
19180          sslip=sscalelip(fracinbuf)
19181          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19182          eliptran=eliptran+sslip*liptranene(itype(i,1))
19183          gliptranx(3,i)=gliptranx(3,i)  &
19184        +ssgradlip*liptranene(itype(i,1))
19185          gliptranc(3,i-1)= gliptranc(3,i-1) &
19186       +ssgradlip*liptranene(itype(i,1))
19187 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19188         else
19189          eliptran=eliptran+liptranene(itype(i,1))
19190 !C         print *,"I am in true lipid"
19191         endif
19192         endif ! if in lipid or buffor
19193 !C       else
19194 !C       eliptran=elpitran+0.0 ! I am in water
19195         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19196        enddo
19197        return
19198        end  subroutine Eliptransfer
19199 !----------------------------------NANO FUNCTIONS
19200 !C-----------------------------------------------------------------------
19201 !C-----------------------------------------------------------
19202 !C This subroutine is to mimic the histone like structure but as well can be
19203 !C utilizet to nanostructures (infinit) small modification has to be used to
19204 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19205 !C gradient has to be modified at the ends
19206 !C The energy function is Kihara potential
19207 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19208 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19209 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19210 !C simple Kihara potential
19211       subroutine calctube(Etube)
19212       real(kind=8),dimension(3) :: vectube
19213       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19214        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19215        sc_aa_tube,sc_bb_tube
19216       integer :: i,j,iti
19217       Etube=0.0d0
19218       do i=itube_start,itube_end
19219         enetube(i)=0.0d0
19220         enetube(i+nres)=0.0d0
19221       enddo
19222 !C first we calculate the distance from tube center
19223 !C for UNRES
19224        do i=itube_start,itube_end
19225 !C lets ommit dummy atoms for now
19226        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19227 !C now calculate distance from center of tube and direction vectors
19228       xmin=boxxsize
19229       ymin=boxysize
19230 ! Find minimum distance in periodic box
19231         do j=-1,1
19232          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19233          vectube(1)=vectube(1)+boxxsize*j
19234          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19235          vectube(2)=vectube(2)+boxysize*j
19236          xminact=abs(vectube(1)-tubecenter(1))
19237          yminact=abs(vectube(2)-tubecenter(2))
19238            if (xmin.gt.xminact) then
19239             xmin=xminact
19240             xtemp=vectube(1)
19241            endif
19242            if (ymin.gt.yminact) then
19243              ymin=yminact
19244              ytemp=vectube(2)
19245             endif
19246          enddo
19247       vectube(1)=xtemp
19248       vectube(2)=ytemp
19249       vectube(1)=vectube(1)-tubecenter(1)
19250       vectube(2)=vectube(2)-tubecenter(2)
19251
19252 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19253 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19254
19255 !C as the tube is infinity we do not calculate the Z-vector use of Z
19256 !C as chosen axis
19257       vectube(3)=0.0d0
19258 !C now calculte the distance
19259        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19260 !C now normalize vector
19261       vectube(1)=vectube(1)/tub_r
19262       vectube(2)=vectube(2)/tub_r
19263 !C calculte rdiffrence between r and r0
19264       rdiff=tub_r-tubeR0
19265 !C and its 6 power
19266       rdiff6=rdiff**6.0d0
19267 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19268        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19269 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19270 !C       print *,rdiff,rdiff6,pep_aa_tube
19271 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19272 !C now we calculate gradient
19273        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19274             6.0d0*pep_bb_tube)/rdiff6/rdiff
19275 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19276 !C     &rdiff,fac
19277 !C now direction of gg_tube vector
19278         do j=1,3
19279         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19280         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19281         enddo
19282         enddo
19283 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19284 !C        print *,gg_tube(1,0),"TU"
19285
19286
19287        do i=itube_start,itube_end
19288 !C Lets not jump over memory as we use many times iti
19289          iti=itype(i,1)
19290 !C lets ommit dummy atoms for now
19291          if ((iti.eq.ntyp1)  &
19292 !C in UNRES uncomment the line below as GLY has no side-chain...
19293 !C      .or.(iti.eq.10)
19294         ) cycle
19295       xmin=boxxsize
19296       ymin=boxysize
19297         do j=-1,1
19298          vectube(1)=mod((c(1,i+nres)),boxxsize)
19299          vectube(1)=vectube(1)+boxxsize*j
19300          vectube(2)=mod((c(2,i+nres)),boxysize)
19301          vectube(2)=vectube(2)+boxysize*j
19302
19303          xminact=abs(vectube(1)-tubecenter(1))
19304          yminact=abs(vectube(2)-tubecenter(2))
19305            if (xmin.gt.xminact) then
19306             xmin=xminact
19307             xtemp=vectube(1)
19308            endif
19309            if (ymin.gt.yminact) then
19310              ymin=yminact
19311              ytemp=vectube(2)
19312             endif
19313          enddo
19314       vectube(1)=xtemp
19315       vectube(2)=ytemp
19316 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19317 !C     &     tubecenter(2)
19318       vectube(1)=vectube(1)-tubecenter(1)
19319       vectube(2)=vectube(2)-tubecenter(2)
19320
19321 !C as the tube is infinity we do not calculate the Z-vector use of Z
19322 !C as chosen axis
19323       vectube(3)=0.0d0
19324 !C now calculte the distance
19325        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19326 !C now normalize vector
19327       vectube(1)=vectube(1)/tub_r
19328       vectube(2)=vectube(2)/tub_r
19329
19330 !C calculte rdiffrence between r and r0
19331       rdiff=tub_r-tubeR0
19332 !C and its 6 power
19333       rdiff6=rdiff**6.0d0
19334 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19335        sc_aa_tube=sc_aa_tube_par(iti)
19336        sc_bb_tube=sc_bb_tube_par(iti)
19337        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19338        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19339              6.0d0*sc_bb_tube/rdiff6/rdiff
19340 !C now direction of gg_tube vector
19341          do j=1,3
19342           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19343           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19344          enddo
19345         enddo
19346         do i=itube_start,itube_end
19347           Etube=Etube+enetube(i)+enetube(i+nres)
19348         enddo
19349 !C        print *,"ETUBE", etube
19350         return
19351         end subroutine calctube
19352 !C TO DO 1) add to total energy
19353 !C       2) add to gradient summation
19354 !C       3) add reading parameters (AND of course oppening of PARAM file)
19355 !C       4) add reading the center of tube
19356 !C       5) add COMMONs
19357 !C       6) add to zerograd
19358 !C       7) allocate matrices
19359
19360
19361 !C-----------------------------------------------------------------------
19362 !C-----------------------------------------------------------
19363 !C This subroutine is to mimic the histone like structure but as well can be
19364 !C utilizet to nanostructures (infinit) small modification has to be used to
19365 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19366 !C gradient has to be modified at the ends
19367 !C The energy function is Kihara potential
19368 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19369 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19370 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19371 !C simple Kihara potential
19372       subroutine calctube2(Etube)
19373             real(kind=8),dimension(3) :: vectube
19374       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19375        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19376        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19377       integer:: i,j,iti
19378       Etube=0.0d0
19379       do i=itube_start,itube_end
19380         enetube(i)=0.0d0
19381         enetube(i+nres)=0.0d0
19382       enddo
19383 !C first we calculate the distance from tube center
19384 !C first sugare-phosphate group for NARES this would be peptide group
19385 !C for UNRES
19386        do i=itube_start,itube_end
19387 !C lets ommit dummy atoms for now
19388
19389        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19390 !C now calculate distance from center of tube and direction vectors
19391 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19392 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19393 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19394 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19395       xmin=boxxsize
19396       ymin=boxysize
19397         do j=-1,1
19398          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19399          vectube(1)=vectube(1)+boxxsize*j
19400          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19401          vectube(2)=vectube(2)+boxysize*j
19402
19403          xminact=abs(vectube(1)-tubecenter(1))
19404          yminact=abs(vectube(2)-tubecenter(2))
19405            if (xmin.gt.xminact) then
19406             xmin=xminact
19407             xtemp=vectube(1)
19408            endif
19409            if (ymin.gt.yminact) then
19410              ymin=yminact
19411              ytemp=vectube(2)
19412             endif
19413          enddo
19414       vectube(1)=xtemp
19415       vectube(2)=ytemp
19416       vectube(1)=vectube(1)-tubecenter(1)
19417       vectube(2)=vectube(2)-tubecenter(2)
19418
19419 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19420 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19421
19422 !C as the tube is infinity we do not calculate the Z-vector use of Z
19423 !C as chosen axis
19424       vectube(3)=0.0d0
19425 !C now calculte the distance
19426        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19427 !C now normalize vector
19428       vectube(1)=vectube(1)/tub_r
19429       vectube(2)=vectube(2)/tub_r
19430 !C calculte rdiffrence between r and r0
19431       rdiff=tub_r-tubeR0
19432 !C and its 6 power
19433       rdiff6=rdiff**6.0d0
19434 !C THIS FRAGMENT MAKES TUBE FINITE
19435         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19436         if (positi.le.0) positi=positi+boxzsize
19437 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19438 !c for each residue check if it is in lipid or lipid water border area
19439 !C       respos=mod(c(3,i+nres),boxzsize)
19440 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19441        if ((positi.gt.bordtubebot)  &
19442         .and.(positi.lt.bordtubetop)) then
19443 !C the energy transfer exist
19444         if (positi.lt.buftubebot) then
19445          fracinbuf=1.0d0-  &
19446            ((positi-bordtubebot)/tubebufthick)
19447 !C lipbufthick is thickenes of lipid buffore
19448          sstube=sscalelip(fracinbuf)
19449          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19450 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19451          enetube(i)=enetube(i)+sstube*tubetranenepep
19452 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19453 !C     &+ssgradtube*tubetranene(itype(i,1))
19454 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19455 !C     &+ssgradtube*tubetranene(itype(i,1))
19456 !C         print *,"doing sccale for lower part"
19457         elseif (positi.gt.buftubetop) then
19458          fracinbuf=1.0d0-  &
19459         ((bordtubetop-positi)/tubebufthick)
19460          sstube=sscalelip(fracinbuf)
19461          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19462          enetube(i)=enetube(i)+sstube*tubetranenepep
19463 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19464 !C     &+ssgradtube*tubetranene(itype(i,1))
19465 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19466 !C     &+ssgradtube*tubetranene(itype(i,1))
19467 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19468         else
19469          sstube=1.0d0
19470          ssgradtube=0.0d0
19471          enetube(i)=enetube(i)+sstube*tubetranenepep
19472 !C         print *,"I am in true lipid"
19473         endif
19474         else
19475 !C          sstube=0.0d0
19476 !C          ssgradtube=0.0d0
19477         cycle
19478         endif ! if in lipid or buffor
19479
19480 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19481        enetube(i)=enetube(i)+sstube* &
19482         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19483 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19484 !C       print *,rdiff,rdiff6,pep_aa_tube
19485 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19486 !C now we calculate gradient
19487        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19488              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19489 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19490 !C     &rdiff,fac
19491
19492 !C now direction of gg_tube vector
19493        do j=1,3
19494         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19495         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19496         enddo
19497          gg_tube(3,i)=gg_tube(3,i)  &
19498        +ssgradtube*enetube(i)/sstube/2.0d0
19499          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19500        +ssgradtube*enetube(i)/sstube/2.0d0
19501
19502         enddo
19503 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19504 !C        print *,gg_tube(1,0),"TU"
19505         do i=itube_start,itube_end
19506 !C Lets not jump over memory as we use many times iti
19507          iti=itype(i,1)
19508 !C lets ommit dummy atoms for now
19509          if ((iti.eq.ntyp1) &
19510 !!C in UNRES uncomment the line below as GLY has no side-chain...
19511            .or.(iti.eq.10) &
19512           ) cycle
19513           vectube(1)=c(1,i+nres)
19514           vectube(1)=mod(vectube(1),boxxsize)
19515           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19516           vectube(2)=c(2,i+nres)
19517           vectube(2)=mod(vectube(2),boxysize)
19518           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19519
19520       vectube(1)=vectube(1)-tubecenter(1)
19521       vectube(2)=vectube(2)-tubecenter(2)
19522 !C THIS FRAGMENT MAKES TUBE FINITE
19523         positi=(mod(c(3,i+nres),boxzsize))
19524         if (positi.le.0) positi=positi+boxzsize
19525 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19526 !c for each residue check if it is in lipid or lipid water border area
19527 !C       respos=mod(c(3,i+nres),boxzsize)
19528 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19529
19530        if ((positi.gt.bordtubebot)  &
19531         .and.(positi.lt.bordtubetop)) then
19532 !C the energy transfer exist
19533         if (positi.lt.buftubebot) then
19534          fracinbuf=1.0d0- &
19535             ((positi-bordtubebot)/tubebufthick)
19536 !C lipbufthick is thickenes of lipid buffore
19537          sstube=sscalelip(fracinbuf)
19538          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19539 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19540          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19541 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19542 !C     &+ssgradtube*tubetranene(itype(i,1))
19543 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19544 !C     &+ssgradtube*tubetranene(itype(i,1))
19545 !C         print *,"doing sccale for lower part"
19546         elseif (positi.gt.buftubetop) then
19547          fracinbuf=1.0d0- &
19548         ((bordtubetop-positi)/tubebufthick)
19549
19550          sstube=sscalelip(fracinbuf)
19551          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19552          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19553 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19554 !C     &+ssgradtube*tubetranene(itype(i,1))
19555 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19556 !C     &+ssgradtube*tubetranene(itype(i,1))
19557 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19558         else
19559          sstube=1.0d0
19560          ssgradtube=0.0d0
19561          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19562 !C         print *,"I am in true lipid"
19563         endif
19564         else
19565 !C          sstube=0.0d0
19566 !C          ssgradtube=0.0d0
19567         cycle
19568         endif ! if in lipid or buffor
19569 !CEND OF FINITE FRAGMENT
19570 !C as the tube is infinity we do not calculate the Z-vector use of Z
19571 !C as chosen axis
19572       vectube(3)=0.0d0
19573 !C now calculte the distance
19574        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19575 !C now normalize vector
19576       vectube(1)=vectube(1)/tub_r
19577       vectube(2)=vectube(2)/tub_r
19578 !C calculte rdiffrence between r and r0
19579       rdiff=tub_r-tubeR0
19580 !C and its 6 power
19581       rdiff6=rdiff**6.0d0
19582 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19583        sc_aa_tube=sc_aa_tube_par(iti)
19584        sc_bb_tube=sc_bb_tube_par(iti)
19585        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19586                        *sstube+enetube(i+nres)
19587 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19588 !C now we calculate gradient
19589        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19590             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19591 !C now direction of gg_tube vector
19592          do j=1,3
19593           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19594           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19595          enddo
19596          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19597        +ssgradtube*enetube(i+nres)/sstube
19598          gg_tube(3,i-1)= gg_tube(3,i-1) &
19599        +ssgradtube*enetube(i+nres)/sstube
19600
19601         enddo
19602         do i=itube_start,itube_end
19603           Etube=Etube+enetube(i)+enetube(i+nres)
19604         enddo
19605 !C        print *,"ETUBE", etube
19606         return
19607         end subroutine calctube2
19608 !=====================================================================================================================================
19609       subroutine calcnano(Etube)
19610       real(kind=8),dimension(3) :: vectube
19611
19612       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19613        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19614        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19615        integer:: i,j,iti,r
19616
19617       Etube=0.0d0
19618 !      print *,itube_start,itube_end,"poczatek"
19619       do i=itube_start,itube_end
19620         enetube(i)=0.0d0
19621         enetube(i+nres)=0.0d0
19622       enddo
19623 !C first we calculate the distance from tube center
19624 !C first sugare-phosphate group for NARES this would be peptide group
19625 !C for UNRES
19626        do i=itube_start,itube_end
19627 !C lets ommit dummy atoms for now
19628        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19629 !C now calculate distance from center of tube and direction vectors
19630       xmin=boxxsize
19631       ymin=boxysize
19632       zmin=boxzsize
19633
19634         do j=-1,1
19635          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19636          vectube(1)=vectube(1)+boxxsize*j
19637          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19638          vectube(2)=vectube(2)+boxysize*j
19639          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19640          vectube(3)=vectube(3)+boxzsize*j
19641
19642
19643          xminact=dabs(vectube(1)-tubecenter(1))
19644          yminact=dabs(vectube(2)-tubecenter(2))
19645          zminact=dabs(vectube(3)-tubecenter(3))
19646
19647            if (xmin.gt.xminact) then
19648             xmin=xminact
19649             xtemp=vectube(1)
19650            endif
19651            if (ymin.gt.yminact) then
19652              ymin=yminact
19653              ytemp=vectube(2)
19654             endif
19655            if (zmin.gt.zminact) then
19656              zmin=zminact
19657              ztemp=vectube(3)
19658             endif
19659          enddo
19660       vectube(1)=xtemp
19661       vectube(2)=ytemp
19662       vectube(3)=ztemp
19663
19664       vectube(1)=vectube(1)-tubecenter(1)
19665       vectube(2)=vectube(2)-tubecenter(2)
19666       vectube(3)=vectube(3)-tubecenter(3)
19667
19668 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19669 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19670 !C as the tube is infinity we do not calculate the Z-vector use of Z
19671 !C as chosen axis
19672 !C      vectube(3)=0.0d0
19673 !C now calculte the distance
19674        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19675 !C now normalize vector
19676       vectube(1)=vectube(1)/tub_r
19677       vectube(2)=vectube(2)/tub_r
19678       vectube(3)=vectube(3)/tub_r
19679 !C calculte rdiffrence between r and r0
19680       rdiff=tub_r-tubeR0
19681 !C and its 6 power
19682       rdiff6=rdiff**6.0d0
19683 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19684        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19685 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19686 !C       print *,rdiff,rdiff6,pep_aa_tube
19687 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19688 !C now we calculate gradient
19689        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19690             6.0d0*pep_bb_tube)/rdiff6/rdiff
19691 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19692 !C     &rdiff,fac
19693          if (acavtubpep.eq.0.0d0) then
19694 !C go to 667
19695          enecavtube(i)=0.0
19696          faccav=0.0
19697          else
19698          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19699          enecavtube(i)=  &
19700         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19701         /denominator
19702          enecavtube(i)=0.0
19703          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19704         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19705         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19706         /denominator**2.0d0
19707 !C         faccav=0.0
19708 !C         fac=fac+faccav
19709 !C 667     continue
19710          endif
19711           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19712         do j=1,3
19713         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19714         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19715         enddo
19716         enddo
19717
19718        do i=itube_start,itube_end
19719         enecavtube(i)=0.0d0
19720 !C Lets not jump over memory as we use many times iti
19721          iti=itype(i,1)
19722 !C lets ommit dummy atoms for now
19723          if ((iti.eq.ntyp1) &
19724 !C in UNRES uncomment the line below as GLY has no side-chain...
19725 !C      .or.(iti.eq.10)
19726          ) cycle
19727       xmin=boxxsize
19728       ymin=boxysize
19729       zmin=boxzsize
19730         do j=-1,1
19731          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19732          vectube(1)=vectube(1)+boxxsize*j
19733          vectube(2)=dmod((c(2,i+nres)),boxysize)
19734          vectube(2)=vectube(2)+boxysize*j
19735          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19736          vectube(3)=vectube(3)+boxzsize*j
19737
19738
19739          xminact=dabs(vectube(1)-tubecenter(1))
19740          yminact=dabs(vectube(2)-tubecenter(2))
19741          zminact=dabs(vectube(3)-tubecenter(3))
19742
19743            if (xmin.gt.xminact) then
19744             xmin=xminact
19745             xtemp=vectube(1)
19746            endif
19747            if (ymin.gt.yminact) then
19748              ymin=yminact
19749              ytemp=vectube(2)
19750             endif
19751            if (zmin.gt.zminact) then
19752              zmin=zminact
19753              ztemp=vectube(3)
19754             endif
19755          enddo
19756       vectube(1)=xtemp
19757       vectube(2)=ytemp
19758       vectube(3)=ztemp
19759
19760 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19761 !C     &     tubecenter(2)
19762       vectube(1)=vectube(1)-tubecenter(1)
19763       vectube(2)=vectube(2)-tubecenter(2)
19764       vectube(3)=vectube(3)-tubecenter(3)
19765 !C now calculte the distance
19766        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19767 !C now normalize vector
19768       vectube(1)=vectube(1)/tub_r
19769       vectube(2)=vectube(2)/tub_r
19770       vectube(3)=vectube(3)/tub_r
19771
19772 !C calculte rdiffrence between r and r0
19773       rdiff=tub_r-tubeR0
19774 !C and its 6 power
19775       rdiff6=rdiff**6.0d0
19776        sc_aa_tube=sc_aa_tube_par(iti)
19777        sc_bb_tube=sc_bb_tube_par(iti)
19778        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19779 !C       enetube(i+nres)=0.0d0
19780 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19781 !C now we calculate gradient
19782        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19783             6.0d0*sc_bb_tube/rdiff6/rdiff
19784 !C       fac=0.0
19785 !C now direction of gg_tube vector
19786 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19787          if (acavtub(iti).eq.0.0d0) then
19788 !C go to 667
19789          enecavtube(i+nres)=0.0d0
19790          faccav=0.0d0
19791          else
19792          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19793          enecavtube(i+nres)=   &
19794         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19795         /denominator
19796 !C         enecavtube(i)=0.0
19797          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19798         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19799         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19800         /denominator**2.0d0
19801 !C         faccav=0.0
19802          fac=fac+faccav
19803 !C 667     continue
19804          endif
19805 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19806 !C     &   enecavtube(i),faccav
19807 !C         print *,"licz=",
19808 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19809 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19810          do j=1,3
19811           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19812           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19813          enddo
19814           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19815         enddo
19816
19817
19818
19819         do i=itube_start,itube_end
19820           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19821          +enecavtube(i+nres)
19822         enddo
19823 !        do i=1,20
19824 !         print *,"begin", i,"a"
19825 !         do r=1,10000
19826 !          rdiff=r/100.0d0
19827 !          rdiff6=rdiff**6.0d0
19828 !          sc_aa_tube=sc_aa_tube_par(i)
19829 !          sc_bb_tube=sc_bb_tube_par(i)
19830 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19831 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19832 !          enecavtube(i)=   &
19833 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19834 !         /denominator
19835
19836 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19837 !         enddo
19838 !         print *,"end",i,"a"
19839 !        enddo
19840 !C        print *,"ETUBE", etube
19841         return
19842         end subroutine calcnano
19843
19844 !===============================================
19845 !--------------------------------------------------------------------------------
19846 !C first for shielding is setting of function of side-chains
19847
19848        subroutine set_shield_fac2
19849        real(kind=8) :: div77_81=0.974996043d0, &
19850         div4_81=0.2222222222d0
19851        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19852          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19853          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19854          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19855 !C the vector between center of side_chain and peptide group
19856        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19857          pept_group,costhet_grad,cosphi_grad_long, &
19858          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19859          sh_frac_dist_grad,pep_side
19860         integer i,j,k
19861 !C      write(2,*) "ivec",ivec_start,ivec_end
19862       do i=1,nres
19863         fac_shield(i)=0.0d0
19864         ishield_list(i)=0
19865         do j=1,3
19866         grad_shield(j,i)=0.0d0
19867         enddo
19868       enddo
19869       do i=ivec_start,ivec_end
19870 !C      do i=1,nres-1
19871 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19872 !      ishield_list(i)=0
19873       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19874 !Cif there two consequtive dummy atoms there is no peptide group between them
19875 !C the line below has to be changed for FGPROC>1
19876       VolumeTotal=0.0
19877       do k=1,nres
19878        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19879        dist_pep_side=0.0
19880        dist_side_calf=0.0
19881        do j=1,3
19882 !C first lets set vector conecting the ithe side-chain with kth side-chain
19883       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19884 !C      pep_side(j)=2.0d0
19885 !C and vector conecting the side-chain with its proper calfa
19886       side_calf(j)=c(j,k+nres)-c(j,k)
19887 !C      side_calf(j)=2.0d0
19888       pept_group(j)=c(j,i)-c(j,i+1)
19889 !C lets have their lenght
19890       dist_pep_side=pep_side(j)**2+dist_pep_side
19891       dist_side_calf=dist_side_calf+side_calf(j)**2
19892       dist_pept_group=dist_pept_group+pept_group(j)**2
19893       enddo
19894        dist_pep_side=sqrt(dist_pep_side)
19895        dist_pept_group=sqrt(dist_pept_group)
19896        dist_side_calf=sqrt(dist_side_calf)
19897       do j=1,3
19898         pep_side_norm(j)=pep_side(j)/dist_pep_side
19899         side_calf_norm(j)=dist_side_calf
19900       enddo
19901 !C now sscale fraction
19902        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19903 !       print *,buff_shield,"buff",sh_frac_dist
19904 !C now sscale
19905         if (sh_frac_dist.le.0.0) cycle
19906 !C        print *,ishield_list(i),i
19907 !C If we reach here it means that this side chain reaches the shielding sphere
19908 !C Lets add him to the list for gradient
19909         ishield_list(i)=ishield_list(i)+1
19910 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19911 !C this list is essential otherwise problem would be O3
19912         shield_list(ishield_list(i),i)=k
19913 !C Lets have the sscale value
19914         if (sh_frac_dist.gt.1.0) then
19915          scale_fac_dist=1.0d0
19916          do j=1,3
19917          sh_frac_dist_grad(j)=0.0d0
19918          enddo
19919         else
19920          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19921                         *(2.0d0*sh_frac_dist-3.0d0)
19922          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19923                        /dist_pep_side/buff_shield*0.5d0
19924          do j=1,3
19925          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19926 !C         sh_frac_dist_grad(j)=0.0d0
19927 !C         scale_fac_dist=1.0d0
19928 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19929 !C     &                    sh_frac_dist_grad(j)
19930          enddo
19931         endif
19932 !C this is what is now we have the distance scaling now volume...
19933       short=short_r_sidechain(itype(k,1))
19934       long=long_r_sidechain(itype(k,1))
19935       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19936       sinthet=short/dist_pep_side*costhet
19937 !      print *,"SORT",short,long,sinthet,costhet
19938 !C now costhet_grad
19939 !C       costhet=0.6d0
19940 !C       sinthet=0.8
19941        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19942 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19943 !C     &             -short/dist_pep_side**2/costhet)
19944 !C       costhet_fac=0.0d0
19945        do j=1,3
19946          costhet_grad(j)=costhet_fac*pep_side(j)
19947        enddo
19948 !C remember for the final gradient multiply costhet_grad(j)
19949 !C for side_chain by factor -2 !
19950 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19951 !C pep_side0pept_group is vector multiplication
19952       pep_side0pept_group=0.0d0
19953       do j=1,3
19954       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19955       enddo
19956       cosalfa=(pep_side0pept_group/ &
19957       (dist_pep_side*dist_side_calf))
19958       fac_alfa_sin=1.0d0-cosalfa**2
19959       fac_alfa_sin=dsqrt(fac_alfa_sin)
19960       rkprim=fac_alfa_sin*(long-short)+short
19961 !C      rkprim=short
19962
19963 !C now costhet_grad
19964        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19965 !C       cosphi=0.6
19966        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19967        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19968            dist_pep_side**2)
19969 !C       sinphi=0.8
19970        do j=1,3
19971          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19972       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19973       *(long-short)/fac_alfa_sin*cosalfa/ &
19974       ((dist_pep_side*dist_side_calf))* &
19975       ((side_calf(j))-cosalfa* &
19976       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19977 !C       cosphi_grad_long(j)=0.0d0
19978         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19979       *(long-short)/fac_alfa_sin*cosalfa &
19980       /((dist_pep_side*dist_side_calf))* &
19981       (pep_side(j)- &
19982       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19983 !C       cosphi_grad_loc(j)=0.0d0
19984        enddo
19985 !C      print *,sinphi,sinthet
19986       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19987                          /VSolvSphere_div
19988 !C     &                    *wshield
19989 !C now the gradient...
19990       do j=1,3
19991       grad_shield(j,i)=grad_shield(j,i) &
19992 !C gradient po skalowaniu
19993                      +(sh_frac_dist_grad(j)*VofOverlap &
19994 !C  gradient po costhet
19995             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19996         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19997             sinphi/sinthet*costhet*costhet_grad(j) &
19998            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19999         )*wshield
20000 !C grad_shield_side is Cbeta sidechain gradient
20001       grad_shield_side(j,ishield_list(i),i)=&
20002              (sh_frac_dist_grad(j)*-2.0d0&
20003              *VofOverlap&
20004             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20005        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20006             sinphi/sinthet*costhet*costhet_grad(j)&
20007            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20008             )*wshield
20009 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20010 !            sinphi/sinthet,&
20011 !           +sinthet/sinphi,"HERE"
20012        grad_shield_loc(j,ishield_list(i),i)=   &
20013             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20014       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20015             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20016              ))&
20017              *wshield
20018 !         print *,grad_shield_loc(j,ishield_list(i),i)
20019       enddo
20020       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20021       enddo
20022       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20023
20024 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20025       enddo
20026       return
20027       end subroutine set_shield_fac2
20028 !----------------------------------------------------------------------------
20029 ! SOUBROUTINE FOR AFM
20030        subroutine AFMvel(Eafmforce)
20031        use MD_data, only:totTafm
20032       real(kind=8),dimension(3) :: diffafm
20033       real(kind=8) :: afmdist,Eafmforce
20034        integer :: i
20035 !C Only for check grad COMMENT if not used for checkgrad
20036 !C      totT=3.0d0
20037 !C--------------------------------------------------------
20038 !C      print *,"wchodze"
20039       afmdist=0.0d0
20040       Eafmforce=0.0d0
20041       do i=1,3
20042       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20043       afmdist=afmdist+diffafm(i)**2
20044       enddo
20045       afmdist=dsqrt(afmdist)
20046 !      totTafm=3.0
20047       Eafmforce=0.5d0*forceAFMconst &
20048       *(distafminit+totTafm*velAFMconst-afmdist)**2
20049 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20050       do i=1,3
20051       gradafm(i,afmend-1)=-forceAFMconst* &
20052        (distafminit+totTafm*velAFMconst-afmdist) &
20053        *diffafm(i)/afmdist
20054       gradafm(i,afmbeg-1)=forceAFMconst* &
20055       (distafminit+totTafm*velAFMconst-afmdist) &
20056       *diffafm(i)/afmdist
20057       enddo
20058 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20059       return
20060       end subroutine AFMvel
20061 !---------------------------------------------------------
20062        subroutine AFMforce(Eafmforce)
20063
20064       real(kind=8),dimension(3) :: diffafm
20065 !      real(kind=8) ::afmdist
20066       real(kind=8) :: afmdist,Eafmforce
20067       integer :: i
20068       afmdist=0.0d0
20069       Eafmforce=0.0d0
20070       do i=1,3
20071       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20072       afmdist=afmdist+diffafm(i)**2
20073       enddo
20074       afmdist=dsqrt(afmdist)
20075 !      print *,afmdist,distafminit
20076       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20077       do i=1,3
20078       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20079       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20080       enddo
20081 !C      print *,'AFM',Eafmforce
20082       return
20083       end subroutine AFMforce
20084
20085 !-----------------------------------------------------------------------------
20086 #ifdef WHAM
20087       subroutine read_ssHist
20088 !      implicit none
20089 !      Includes
20090 !      include 'DIMENSIONS'
20091 !      include "DIMENSIONS.FREE"
20092 !      include 'COMMON.FREE'
20093 !     Local variables
20094       integer :: i,j
20095       character(len=80) :: controlcard
20096
20097       do i=1,dyn_nssHist
20098         call card_concat(controlcard,.true.)
20099         read(controlcard,*) &
20100              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20101       enddo
20102
20103       return
20104       end subroutine read_ssHist
20105 #endif
20106 !-----------------------------------------------------------------------------
20107       integer function indmat(i,j)
20108 !el
20109 ! get the position of the jth ijth fragment of the chain coordinate system
20110 ! in the fromto array.
20111         integer :: i,j
20112
20113         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20114       return
20115       end function indmat
20116 !-----------------------------------------------------------------------------
20117       real(kind=8) function sigm(x)
20118 !el
20119        real(kind=8) :: x
20120         sigm=0.25d0*x
20121       return
20122       end function sigm
20123 !-----------------------------------------------------------------------------
20124 !-----------------------------------------------------------------------------
20125       subroutine alloc_ener_arrays
20126 !EL Allocation of arrays used by module energy
20127       use MD_data, only: mset
20128 !el local variables
20129       integer :: i,j
20130
20131       if(nres.lt.100) then
20132         maxconts=10*nres
20133       elseif(nres.lt.200) then
20134         maxconts=10*nres      ! Max. number of contacts per residue
20135       else
20136         maxconts=10*nres ! (maxconts=maxres/4)
20137       endif
20138       maxcont=12*nres      ! Max. number of SC contacts
20139       maxvar=6*nres      ! Max. number of variables
20140 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20141       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20142 !----------------------
20143 ! arrays in subroutine init_int_table
20144 !el#ifdef MPI
20145 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20146 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20147 !el#endif
20148       allocate(nint_gr(nres))
20149       allocate(nscp_gr(nres))
20150       allocate(ielstart(nres))
20151       allocate(ielend(nres))
20152 !(maxres)
20153       allocate(istart(nres,maxint_gr))
20154       allocate(iend(nres,maxint_gr))
20155 !(maxres,maxint_gr)
20156       allocate(iscpstart(nres,maxint_gr))
20157       allocate(iscpend(nres,maxint_gr))
20158 !(maxres,maxint_gr)
20159       allocate(ielstart_vdw(nres))
20160       allocate(ielend_vdw(nres))
20161 !(maxres)
20162       allocate(nint_gr_nucl(nres))
20163       allocate(nscp_gr_nucl(nres))
20164       allocate(ielstart_nucl(nres))
20165       allocate(ielend_nucl(nres))
20166 !(maxres)
20167       allocate(istart_nucl(nres,maxint_gr))
20168       allocate(iend_nucl(nres,maxint_gr))
20169 !(maxres,maxint_gr)
20170       allocate(iscpstart_nucl(nres,maxint_gr))
20171       allocate(iscpend_nucl(nres,maxint_gr))
20172 !(maxres,maxint_gr)
20173       allocate(ielstart_vdw_nucl(nres))
20174       allocate(ielend_vdw_nucl(nres))
20175
20176       allocate(lentyp(0:nfgtasks-1))
20177 !(0:maxprocs-1)
20178 !----------------------
20179 ! commom.contacts
20180 !      common /contacts/
20181       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20182       allocate(icont(2,maxcont))
20183 !(2,maxcont)
20184 !      common /contacts1/
20185       allocate(num_cont(0:nres+4))
20186 !(maxres)
20187       allocate(jcont(maxconts,nres))
20188 !(maxconts,maxres)
20189       allocate(facont(maxconts,nres))
20190 !(maxconts,maxres)
20191       allocate(gacont(3,maxconts,nres))
20192 !(3,maxconts,maxres)
20193 !      common /contacts_hb/
20194       allocate(gacontp_hb1(3,maxconts,nres))
20195       allocate(gacontp_hb2(3,maxconts,nres))
20196       allocate(gacontp_hb3(3,maxconts,nres))
20197       allocate(gacontm_hb1(3,maxconts,nres))
20198       allocate(gacontm_hb2(3,maxconts,nres))
20199       allocate(gacontm_hb3(3,maxconts,nres))
20200       allocate(gacont_hbr(3,maxconts,nres))
20201       allocate(grij_hb_cont(3,maxconts,nres))
20202 !(3,maxconts,maxres)
20203       allocate(facont_hb(maxconts,nres))
20204
20205       allocate(ees0p(maxconts,nres))
20206       allocate(ees0m(maxconts,nres))
20207       allocate(d_cont(maxconts,nres))
20208       allocate(ees0plist(maxconts,nres))
20209
20210 !(maxconts,maxres)
20211       allocate(num_cont_hb(nres))
20212 !(maxres)
20213       allocate(jcont_hb(maxconts,nres))
20214 !(maxconts,maxres)
20215 !      common /rotat/
20216       allocate(Ug(2,2,nres))
20217       allocate(Ugder(2,2,nres))
20218       allocate(Ug2(2,2,nres))
20219       allocate(Ug2der(2,2,nres))
20220 !(2,2,maxres)
20221       allocate(obrot(2,nres))
20222       allocate(obrot2(2,nres))
20223       allocate(obrot_der(2,nres))
20224       allocate(obrot2_der(2,nres))
20225 !(2,maxres)
20226 !      common /precomp1/
20227       allocate(mu(2,nres))
20228       allocate(muder(2,nres))
20229       allocate(Ub2(2,nres))
20230       Ub2(1,:)=0.0d0
20231       Ub2(2,:)=0.0d0
20232       allocate(Ub2der(2,nres))
20233       allocate(Ctobr(2,nres))
20234       allocate(Ctobrder(2,nres))
20235       allocate(Dtobr2(2,nres))
20236       allocate(Dtobr2der(2,nres))
20237 !(2,maxres)
20238       allocate(EUg(2,2,nres))
20239       allocate(EUgder(2,2,nres))
20240       allocate(CUg(2,2,nres))
20241       allocate(CUgder(2,2,nres))
20242       allocate(DUg(2,2,nres))
20243       allocate(Dugder(2,2,nres))
20244       allocate(DtUg2(2,2,nres))
20245       allocate(DtUg2der(2,2,nres))
20246 !(2,2,maxres)
20247 !      common /precomp2/
20248       allocate(Ug2Db1t(2,nres))
20249       allocate(Ug2Db1tder(2,nres))
20250       allocate(CUgb2(2,nres))
20251       allocate(CUgb2der(2,nres))
20252 !(2,maxres)
20253       allocate(EUgC(2,2,nres))
20254       allocate(EUgCder(2,2,nres))
20255       allocate(EUgD(2,2,nres))
20256       allocate(EUgDder(2,2,nres))
20257       allocate(DtUg2EUg(2,2,nres))
20258       allocate(Ug2DtEUg(2,2,nres))
20259 !(2,2,maxres)
20260       allocate(Ug2DtEUgder(2,2,2,nres))
20261       allocate(DtUg2EUgder(2,2,2,nres))
20262 !(2,2,2,maxres)
20263       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20264       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20265       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20266       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20267
20268       allocate(ctilde(2,2,nres))
20269       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20270       allocate(gtb1(2,nres))
20271       allocate(gtb2(2,nres))
20272       allocate(cc(2,2,nres))
20273       allocate(dd(2,2,nres))
20274       allocate(ee(2,2,nres))
20275       allocate(gtcc(2,2,nres))
20276       allocate(gtdd(2,2,nres))
20277       allocate(gtee(2,2,nres))
20278       allocate(gUb2(2,nres))
20279       allocate(gteUg(2,2,nres))
20280
20281 !      common /rotat_old/
20282       allocate(costab(nres))
20283       allocate(sintab(nres))
20284       allocate(costab2(nres))
20285       allocate(sintab2(nres))
20286 !(maxres)
20287 !      common /dipmat/
20288       allocate(a_chuj(2,2,maxconts,nres))
20289 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20290       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20291 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20292 !      common /contdistrib/
20293       allocate(ncont_sent(nres))
20294       allocate(ncont_recv(nres))
20295
20296       allocate(iat_sent(nres))
20297 !(maxres)
20298       allocate(iint_sent(4,nres,nres))
20299       allocate(iint_sent_local(4,nres,nres))
20300 !(4,maxres,maxres)
20301       allocate(iturn3_sent(4,0:nres+4))
20302       allocate(iturn4_sent(4,0:nres+4))
20303       allocate(iturn3_sent_local(4,nres))
20304       allocate(iturn4_sent_local(4,nres))
20305 !(4,maxres)
20306       allocate(itask_cont_from(0:nfgtasks-1))
20307       allocate(itask_cont_to(0:nfgtasks-1))
20308 !(0:max_fg_procs-1)
20309
20310
20311
20312 !----------------------
20313 ! commom.deriv;
20314 !      common /derivat/
20315       allocate(dcdv(6,maxdim))
20316       allocate(dxdv(6,maxdim))
20317 !(6,maxdim)
20318       allocate(dxds(6,nres))
20319 !(6,maxres)
20320       allocate(gradx(3,-1:nres,0:2))
20321       allocate(gradc(3,-1:nres,0:2))
20322 !(3,maxres,2)
20323       allocate(gvdwx(3,-1:nres))
20324       allocate(gvdwc(3,-1:nres))
20325       allocate(gelc(3,-1:nres))
20326       allocate(gelc_long(3,-1:nres))
20327       allocate(gvdwpp(3,-1:nres))
20328       allocate(gvdwc_scpp(3,-1:nres))
20329       allocate(gradx_scp(3,-1:nres))
20330       allocate(gvdwc_scp(3,-1:nres))
20331       allocate(ghpbx(3,-1:nres))
20332       allocate(ghpbc(3,-1:nres))
20333       allocate(gradcorr(3,-1:nres))
20334       allocate(gradcorr_long(3,-1:nres))
20335       allocate(gradcorr5_long(3,-1:nres))
20336       allocate(gradcorr6_long(3,-1:nres))
20337       allocate(gcorr6_turn_long(3,-1:nres))
20338       allocate(gradxorr(3,-1:nres))
20339       allocate(gradcorr5(3,-1:nres))
20340       allocate(gradcorr6(3,-1:nres))
20341       allocate(gliptran(3,-1:nres))
20342       allocate(gliptranc(3,-1:nres))
20343       allocate(gliptranx(3,-1:nres))
20344       allocate(gshieldx(3,-1:nres))
20345       allocate(gshieldc(3,-1:nres))
20346       allocate(gshieldc_loc(3,-1:nres))
20347       allocate(gshieldx_ec(3,-1:nres))
20348       allocate(gshieldc_ec(3,-1:nres))
20349       allocate(gshieldc_loc_ec(3,-1:nres))
20350       allocate(gshieldx_t3(3,-1:nres))
20351       allocate(gshieldc_t3(3,-1:nres))
20352       allocate(gshieldc_loc_t3(3,-1:nres))
20353       allocate(gshieldx_t4(3,-1:nres))
20354       allocate(gshieldc_t4(3,-1:nres))
20355       allocate(gshieldc_loc_t4(3,-1:nres))
20356       allocate(gshieldx_ll(3,-1:nres))
20357       allocate(gshieldc_ll(3,-1:nres))
20358       allocate(gshieldc_loc_ll(3,-1:nres))
20359       allocate(grad_shield(3,-1:nres))
20360       allocate(gg_tube_sc(3,-1:nres))
20361       allocate(gg_tube(3,-1:nres))
20362       allocate(gradafm(3,-1:nres))
20363       allocate(gradb_nucl(3,-1:nres))
20364       allocate(gradbx_nucl(3,-1:nres))
20365       allocate(gvdwpsb1(3,-1:nres))
20366       allocate(gelpp(3,-1:nres))
20367       allocate(gvdwpsb(3,-1:nres))
20368       allocate(gelsbc(3,-1:nres))
20369       allocate(gelsbx(3,-1:nres))
20370       allocate(gvdwsbx(3,-1:nres))
20371       allocate(gvdwsbc(3,-1:nres))
20372       allocate(gsbloc(3,-1:nres))
20373       allocate(gsblocx(3,-1:nres))
20374       allocate(gradcorr_nucl(3,-1:nres))
20375       allocate(gradxorr_nucl(3,-1:nres))
20376       allocate(gradcorr3_nucl(3,-1:nres))
20377       allocate(gradxorr3_nucl(3,-1:nres))
20378       allocate(gvdwpp_nucl(3,-1:nres))
20379       allocate(gradpepcat(3,-1:nres))
20380       allocate(gradpepcatx(3,-1:nres))
20381       allocate(gradcatcat(3,-1:nres))
20382 !(3,maxres)
20383       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20384       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20385 ! grad for shielding surroing
20386       allocate(gloc(0:maxvar,0:2))
20387       allocate(gloc_x(0:maxvar,2))
20388 !(maxvar,2)
20389       allocate(gel_loc(3,-1:nres))
20390       allocate(gel_loc_long(3,-1:nres))
20391       allocate(gcorr3_turn(3,-1:nres))
20392       allocate(gcorr4_turn(3,-1:nres))
20393       allocate(gcorr6_turn(3,-1:nres))
20394       allocate(gradb(3,-1:nres))
20395       allocate(gradbx(3,-1:nres))
20396 !(3,maxres)
20397       allocate(gel_loc_loc(maxvar))
20398       allocate(gel_loc_turn3(maxvar))
20399       allocate(gel_loc_turn4(maxvar))
20400       allocate(gel_loc_turn6(maxvar))
20401       allocate(gcorr_loc(maxvar))
20402       allocate(g_corr5_loc(maxvar))
20403       allocate(g_corr6_loc(maxvar))
20404 !(maxvar)
20405       allocate(gsccorc(3,-1:nres))
20406       allocate(gsccorx(3,-1:nres))
20407 !(3,maxres)
20408       allocate(gsccor_loc(-1:nres))
20409 !(maxres)
20410       allocate(gvdwx_scbase(3,-1:nres))
20411       allocate(gvdwc_scbase(3,-1:nres))
20412       allocate(gvdwx_pepbase(3,-1:nres))
20413       allocate(gvdwc_pepbase(3,-1:nres))
20414       allocate(gvdwx_scpho(3,-1:nres))
20415       allocate(gvdwc_scpho(3,-1:nres))
20416       allocate(gvdwc_peppho(3,-1:nres))
20417
20418       allocate(dtheta(3,2,-1:nres))
20419 !(3,2,maxres)
20420       allocate(gscloc(3,-1:nres))
20421       allocate(gsclocx(3,-1:nres))
20422 !(3,maxres)
20423       allocate(dphi(3,3,-1:nres))
20424       allocate(dalpha(3,3,-1:nres))
20425       allocate(domega(3,3,-1:nres))
20426 !(3,3,maxres)
20427 !      common /deriv_scloc/
20428       allocate(dXX_C1tab(3,nres))
20429       allocate(dYY_C1tab(3,nres))
20430       allocate(dZZ_C1tab(3,nres))
20431       allocate(dXX_Ctab(3,nres))
20432       allocate(dYY_Ctab(3,nres))
20433       allocate(dZZ_Ctab(3,nres))
20434       allocate(dXX_XYZtab(3,nres))
20435       allocate(dYY_XYZtab(3,nres))
20436       allocate(dZZ_XYZtab(3,nres))
20437 !(3,maxres)
20438 !      common /mpgrad/
20439       allocate(jgrad_start(nres))
20440       allocate(jgrad_end(nres))
20441 !(maxres)
20442 !----------------------
20443
20444 !      common /indices/
20445       allocate(ibond_displ(0:nfgtasks-1))
20446       allocate(ibond_count(0:nfgtasks-1))
20447       allocate(ithet_displ(0:nfgtasks-1))
20448       allocate(ithet_count(0:nfgtasks-1))
20449       allocate(iphi_displ(0:nfgtasks-1))
20450       allocate(iphi_count(0:nfgtasks-1))
20451       allocate(iphi1_displ(0:nfgtasks-1))
20452       allocate(iphi1_count(0:nfgtasks-1))
20453       allocate(ivec_displ(0:nfgtasks-1))
20454       allocate(ivec_count(0:nfgtasks-1))
20455       allocate(iset_displ(0:nfgtasks-1))
20456       allocate(iset_count(0:nfgtasks-1))
20457       allocate(iint_count(0:nfgtasks-1))
20458       allocate(iint_displ(0:nfgtasks-1))
20459 !(0:max_fg_procs-1)
20460 !----------------------
20461 ! common.MD
20462 !      common /mdgrad/
20463       allocate(gcart(3,-1:nres))
20464       allocate(gxcart(3,-1:nres))
20465 !(3,0:MAXRES)
20466       allocate(gradcag(3,-1:nres))
20467       allocate(gradxag(3,-1:nres))
20468 !(3,MAXRES)
20469 !      common /back_constr/
20470 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20471       allocate(dutheta(nres))
20472       allocate(dugamma(nres))
20473 !(maxres)
20474       allocate(duscdiff(3,nres))
20475       allocate(duscdiffx(3,nres))
20476 !(3,maxres)
20477 !el i io:read_fragments
20478 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20479 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20480 !      common /qmeas/
20481 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20482 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20483       allocate(mset(0:nprocs))  !(maxprocs/20)
20484       mset(:)=0
20485 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20486 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20487       allocate(dUdconst(3,0:nres))
20488       allocate(dUdxconst(3,0:nres))
20489       allocate(dqwol(3,0:nres))
20490       allocate(dxqwol(3,0:nres))
20491 !(3,0:MAXRES)
20492 !----------------------
20493 ! common.sbridge
20494 !      common /sbridge/ in io_common: read_bridge
20495 !el    allocate((:),allocatable :: iss      !(maxss)
20496 !      common /links/  in io_common: read_bridge
20497 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20498 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20499 !      common /dyn_ssbond/
20500 ! and side-chain vectors in theta or phi.
20501       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20502 !(maxres,maxres)
20503 !      do i=1,nres
20504 !        do j=i+1,nres
20505       dyn_ssbond_ij(:,:)=1.0d300
20506 !        enddo
20507 !      enddo
20508
20509 !      if (nss.gt.0) then
20510         allocate(idssb(maxdim),jdssb(maxdim))
20511 !        allocate(newihpb(nss),newjhpb(nss))
20512 !(maxdim)
20513 !      endif
20514       allocate(ishield_list(-1:nres))
20515       allocate(shield_list(maxcontsshi,-1:nres))
20516       allocate(dyn_ss_mask(nres))
20517       allocate(fac_shield(-1:nres))
20518       allocate(enetube(nres*2))
20519       allocate(enecavtube(nres*2))
20520
20521 !(maxres)
20522       dyn_ss_mask(:)=.false.
20523 !----------------------
20524 ! common.sccor
20525 ! Parameters of the SCCOR term
20526 !      common/sccor/
20527 !el in io_conf: parmread
20528 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20529 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20530 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20531 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20532 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20533 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20534 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20535 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20536 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20537 !----------------
20538       allocate(gloc_sc(3,0:2*nres,0:10))
20539 !(3,0:maxres2,10)maxres2=2*maxres
20540       allocate(dcostau(3,3,3,2*nres))
20541       allocate(dsintau(3,3,3,2*nres))
20542       allocate(dtauangle(3,3,3,2*nres))
20543       allocate(dcosomicron(3,3,3,2*nres))
20544       allocate(domicron(3,3,3,2*nres))
20545 !(3,3,3,maxres2)maxres2=2*maxres
20546 !----------------------
20547 ! common.var
20548 !      common /restr/
20549       allocate(varall(maxvar))
20550 !(maxvar)(maxvar=6*maxres)
20551       allocate(mask_theta(nres))
20552       allocate(mask_phi(nres))
20553       allocate(mask_side(nres))
20554 !(maxres)
20555 !----------------------
20556 ! common.vectors
20557 !      common /vectors/
20558       allocate(uy(3,nres))
20559       allocate(uz(3,nres))
20560 !(3,maxres)
20561       allocate(uygrad(3,3,2,nres))
20562       allocate(uzgrad(3,3,2,nres))
20563 !(3,3,2,maxres)
20564 ! allocateion of lists JPRDLA
20565       allocate(newcontlistppi(200*nres))
20566       allocate(newcontlistscpi(200*nres))
20567       allocate(newcontlisti(200*nres))
20568       allocate(newcontlistppj(200*nres))
20569       allocate(newcontlistscpj(200*nres))
20570       allocate(newcontlistj(200*nres))
20571
20572       return
20573       end subroutine alloc_ener_arrays
20574 !-----------------------------------------------------------------
20575       subroutine ebond_nucl(estr_nucl)
20576 !c
20577 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20578 !c
20579
20580       real(kind=8),dimension(3) :: u,ud
20581       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20582       real(kind=8) :: estr_nucl,diff
20583       integer :: iti,i,j,k,nbi
20584       estr_nucl=0.0d0
20585 !C      print *,"I enter ebond"
20586       if (energy_dec) &
20587       write (iout,*) "ibondp_start,ibondp_end",&
20588        ibondp_nucl_start,ibondp_nucl_end
20589       do i=ibondp_nucl_start,ibondp_nucl_end
20590         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20591          itype(i,2).eq.ntyp1_molec(2)) cycle
20592 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20593 !          do j=1,3
20594 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20595 !     &      *dc(j,i-1)/vbld(i)
20596 !          enddo
20597 !          if (energy_dec) write(iout,*)
20598 !     &       "estr1",i,vbld(i),distchainmax,
20599 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20600
20601           diff = vbld(i)-vbldp0_nucl
20602           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20603           vbldp0_nucl,diff,AKP_nucl*diff*diff
20604           estr_nucl=estr_nucl+diff*diff
20605 !          print *,estr_nucl
20606           do j=1,3
20607             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20608           enddo
20609 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20610       enddo
20611       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20612 !      print *,"partial sum", estr_nucl,AKP_nucl
20613
20614       if (energy_dec) &
20615       write (iout,*) "ibondp_start,ibondp_end",&
20616        ibond_nucl_start,ibond_nucl_end
20617
20618       do i=ibond_nucl_start,ibond_nucl_end
20619 !C        print *, "I am stuck",i
20620         iti=itype(i,2)
20621         if (iti.eq.ntyp1_molec(2)) cycle
20622           nbi=nbondterm_nucl(iti)
20623 !C        print *,iti,nbi
20624           if (nbi.eq.1) then
20625             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20626
20627             if (energy_dec) &
20628            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20629            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20630             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20631 !            print *,estr_nucl
20632             do j=1,3
20633               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20634             enddo
20635           else
20636             do j=1,nbi
20637               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20638               ud(j)=aksc_nucl(j,iti)*diff
20639               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20640             enddo
20641             uprod=u(1)
20642             do j=2,nbi
20643               uprod=uprod*u(j)
20644             enddo
20645             usum=0.0d0
20646             usumsqder=0.0d0
20647             do j=1,nbi
20648               uprod1=1.0d0
20649               uprod2=1.0d0
20650               do k=1,nbi
20651                 if (k.ne.j) then
20652                   uprod1=uprod1*u(k)
20653                   uprod2=uprod2*u(k)*u(k)
20654                 endif
20655               enddo
20656               usum=usum+uprod1
20657               usumsqder=usumsqder+ud(j)*uprod2
20658             enddo
20659             estr_nucl=estr_nucl+uprod/usum
20660             do j=1,3
20661              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20662             enddo
20663         endif
20664       enddo
20665 !C      print *,"I am about to leave ebond"
20666       return
20667       end subroutine ebond_nucl
20668
20669 !-----------------------------------------------------------------------------
20670       subroutine ebend_nucl(etheta_nucl)
20671       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20672       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20673       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20674       logical :: lprn=.false., lprn1=.false.
20675 !el local variables
20676       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20677       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20678       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20679 ! local variables for constrains
20680       real(kind=8) :: difi,thetiii
20681        integer itheta
20682       etheta_nucl=0.0D0
20683 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20684       do i=ithet_nucl_start,ithet_nucl_end
20685         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20686         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20687         (itype(i,2).eq.ntyp1_molec(2))) cycle
20688         dethetai=0.0d0
20689         dephii=0.0d0
20690         dephii1=0.0d0
20691         theti2=0.5d0*theta(i)
20692         ityp2=ithetyp_nucl(itype(i-1,2))
20693         do k=1,nntheterm_nucl
20694           coskt(k)=dcos(k*theti2)
20695           sinkt(k)=dsin(k*theti2)
20696         enddo
20697         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20698 #ifdef OSF
20699           phii=phi(i)
20700           if (phii.ne.phii) phii=150.0
20701 #else
20702           phii=phi(i)
20703 #endif
20704           ityp1=ithetyp_nucl(itype(i-2,2))
20705           do k=1,nsingle_nucl
20706             cosph1(k)=dcos(k*phii)
20707             sinph1(k)=dsin(k*phii)
20708           enddo
20709         else
20710           phii=0.0d0
20711           ityp1=nthetyp_nucl+1
20712           do k=1,nsingle_nucl
20713             cosph1(k)=0.0d0
20714             sinph1(k)=0.0d0
20715           enddo
20716         endif
20717
20718         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20719 #ifdef OSF
20720           phii1=phi(i+1)
20721           if (phii1.ne.phii1) phii1=150.0
20722           phii1=pinorm(phii1)
20723 #else
20724           phii1=phi(i+1)
20725 #endif
20726           ityp3=ithetyp_nucl(itype(i,2))
20727           do k=1,nsingle_nucl
20728             cosph2(k)=dcos(k*phii1)
20729             sinph2(k)=dsin(k*phii1)
20730           enddo
20731         else
20732           phii1=0.0d0
20733           ityp3=nthetyp_nucl+1
20734           do k=1,nsingle_nucl
20735             cosph2(k)=0.0d0
20736             sinph2(k)=0.0d0
20737           enddo
20738         endif
20739         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20740         do k=1,ndouble_nucl
20741           do l=1,k-1
20742             ccl=cosph1(l)*cosph2(k-l)
20743             ssl=sinph1(l)*sinph2(k-l)
20744             scl=sinph1(l)*cosph2(k-l)
20745             csl=cosph1(l)*sinph2(k-l)
20746             cosph1ph2(l,k)=ccl-ssl
20747             cosph1ph2(k,l)=ccl+ssl
20748             sinph1ph2(l,k)=scl+csl
20749             sinph1ph2(k,l)=scl-csl
20750           enddo
20751         enddo
20752         if (lprn) then
20753         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20754          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20755         write (iout,*) "coskt and sinkt",nntheterm_nucl
20756         do k=1,nntheterm_nucl
20757           write (iout,*) k,coskt(k),sinkt(k)
20758         enddo
20759         endif
20760         do k=1,ntheterm_nucl
20761           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20762           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20763            *coskt(k)
20764           if (lprn)&
20765          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20766           " ethetai",ethetai
20767         enddo
20768         if (lprn) then
20769         write (iout,*) "cosph and sinph"
20770         do k=1,nsingle_nucl
20771           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20772         enddo
20773         write (iout,*) "cosph1ph2 and sinph2ph2"
20774         do k=2,ndouble_nucl
20775           do l=1,k-1
20776             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20777               sinph1ph2(l,k),sinph1ph2(k,l)
20778           enddo
20779         enddo
20780         write(iout,*) "ethetai",ethetai
20781         endif
20782         do m=1,ntheterm2_nucl
20783           do k=1,nsingle_nucl
20784             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20785               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20786               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20787               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20788             ethetai=ethetai+sinkt(m)*aux
20789             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20790             dephii=dephii+k*sinkt(m)*(&
20791                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20792                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20793             dephii1=dephii1+k*sinkt(m)*(&
20794                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20795                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20796             if (lprn) &
20797            write (iout,*) "m",m," k",k," bbthet",&
20798               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20799               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20800               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20801               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20802           enddo
20803         enddo
20804         if (lprn) &
20805         write(iout,*) "ethetai",ethetai
20806         do m=1,ntheterm3_nucl
20807           do k=2,ndouble_nucl
20808             do l=1,k-1
20809               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20810                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20811                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20812                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20813               ethetai=ethetai+sinkt(m)*aux
20814               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20815               dephii=dephii+l*sinkt(m)*(&
20816                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20817                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20818                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20819                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20820               dephii1=dephii1+(k-l)*sinkt(m)*( &
20821                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20822                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20823                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20824                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20825               if (lprn) then
20826               write (iout,*) "m",m," k",k," l",l," ffthet", &
20827                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20828                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20829                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20830                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20831               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20832                  cosph1ph2(k,l)*sinkt(m),&
20833                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20834               endif
20835             enddo
20836           enddo
20837         enddo
20838 10      continue
20839         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20840         i,theta(i)*rad2deg,phii*rad2deg, &
20841         phii1*rad2deg,ethetai
20842         etheta_nucl=etheta_nucl+ethetai
20843 !        print *,i,"partial sum",etheta_nucl
20844         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20845         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20846         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20847       enddo
20848       return
20849       end subroutine ebend_nucl
20850 !----------------------------------------------------
20851       subroutine etor_nucl(etors_nucl)
20852 !      implicit real*8 (a-h,o-z)
20853 !      include 'DIMENSIONS'
20854 !      include 'COMMON.VAR'
20855 !      include 'COMMON.GEO'
20856 !      include 'COMMON.LOCAL'
20857 !      include 'COMMON.TORSION'
20858 !      include 'COMMON.INTERACT'
20859 !      include 'COMMON.DERIV'
20860 !      include 'COMMON.CHAIN'
20861 !      include 'COMMON.NAMES'
20862 !      include 'COMMON.IOUNITS'
20863 !      include 'COMMON.FFIELD'
20864 !      include 'COMMON.TORCNSTR'
20865 !      include 'COMMON.CONTROL'
20866       real(kind=8) :: etors_nucl,edihcnstr
20867       logical :: lprn
20868 !el local variables
20869       integer :: i,j,iblock,itori,itori1
20870       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20871                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20872 ! Set lprn=.true. for debugging
20873       lprn=.false.
20874 !     lprn=.true.
20875       etors_nucl=0.0D0
20876 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20877       do i=iphi_nucl_start,iphi_nucl_end
20878         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20879              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20880              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20881         etors_ii=0.0D0
20882         itori=itortyp_nucl(itype(i-2,2))
20883         itori1=itortyp_nucl(itype(i-1,2))
20884         phii=phi(i)
20885 !         print *,i,itori,itori1
20886         gloci=0.0D0
20887 !C Regular cosine and sine terms
20888         do j=1,nterm_nucl(itori,itori1)
20889           v1ij=v1_nucl(j,itori,itori1)
20890           v2ij=v2_nucl(j,itori,itori1)
20891           cosphi=dcos(j*phii)
20892           sinphi=dsin(j*phii)
20893           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20894           if (energy_dec) etors_ii=etors_ii+&
20895                      v1ij*cosphi+v2ij*sinphi
20896           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20897         enddo
20898 !C Lorentz terms
20899 !C                         v1
20900 !C  E = SUM ----------------------------------- - v1
20901 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20902 !C
20903         cosphi=dcos(0.5d0*phii)
20904         sinphi=dsin(0.5d0*phii)
20905         do j=1,nlor_nucl(itori,itori1)
20906           vl1ij=vlor1_nucl(j,itori,itori1)
20907           vl2ij=vlor2_nucl(j,itori,itori1)
20908           vl3ij=vlor3_nucl(j,itori,itori1)
20909           pom=vl2ij*cosphi+vl3ij*sinphi
20910           pom1=1.0d0/(pom*pom+1.0d0)
20911           etors_nucl=etors_nucl+vl1ij*pom1
20912           if (energy_dec) etors_ii=etors_ii+ &
20913                      vl1ij*pom1
20914           pom=-pom*pom1*pom1
20915           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20916         enddo
20917 !C Subtract the constant term
20918         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20919           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20920               'etor',i,etors_ii-v0_nucl(itori,itori1)
20921         if (lprn) &
20922        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20923        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20924        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20925         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20926 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20927       enddo
20928       return
20929       end subroutine etor_nucl
20930 !------------------------------------------------------------
20931       subroutine epp_nucl_sub(evdw1,ees)
20932 !C
20933 !C This subroutine calculates the average interaction energy and its gradient
20934 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20935 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20936 !C The potential depends both on the distance of peptide-group centers and on
20937 !C the orientation of the CA-CA virtual bonds.
20938 !C
20939       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20940       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20941       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20942                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20943                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20944       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20945                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20946       integer xshift,yshift,zshift
20947       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20948       real(kind=8) :: ees,eesij
20949 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20950       real(kind=8) scal_el /0.5d0/
20951       t_eelecij=0.0d0
20952       ees=0.0D0
20953       evdw1=0.0D0
20954       ind=0
20955 !c
20956 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20957 !c
20958 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20959       do i=iatel_s_nucl,iatel_e_nucl
20960         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20961         dxi=dc(1,i)
20962         dyi=dc(2,i)
20963         dzi=dc(3,i)
20964         dx_normi=dc_norm(1,i)
20965         dy_normi=dc_norm(2,i)
20966         dz_normi=dc_norm(3,i)
20967         xmedi=c(1,i)+0.5d0*dxi
20968         ymedi=c(2,i)+0.5d0*dyi
20969         zmedi=c(3,i)+0.5d0*dzi
20970           xmedi=dmod(xmedi,boxxsize)
20971           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20972           ymedi=dmod(ymedi,boxysize)
20973           if (ymedi.lt.0) ymedi=ymedi+boxysize
20974           zmedi=dmod(zmedi,boxzsize)
20975           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20976
20977         do j=ielstart_nucl(i),ielend_nucl(i)
20978           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20979           ind=ind+1
20980           dxj=dc(1,j)
20981           dyj=dc(2,j)
20982           dzj=dc(3,j)
20983 !          xj=c(1,j)+0.5D0*dxj-xmedi
20984 !          yj=c(2,j)+0.5D0*dyj-ymedi
20985 !          zj=c(3,j)+0.5D0*dzj-zmedi
20986           xj=c(1,j)+0.5D0*dxj
20987           yj=c(2,j)+0.5D0*dyj
20988           zj=c(3,j)+0.5D0*dzj
20989           xj=mod(xj,boxxsize)
20990           if (xj.lt.0) xj=xj+boxxsize
20991           yj=mod(yj,boxysize)
20992           if (yj.lt.0) yj=yj+boxysize
20993           zj=mod(zj,boxzsize)
20994           if (zj.lt.0) zj=zj+boxzsize
20995       isubchap=0
20996       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20997       xj_safe=xj
20998       yj_safe=yj
20999       zj_safe=zj
21000       do xshift=-1,1
21001       do yshift=-1,1
21002       do zshift=-1,1
21003           xj=xj_safe+xshift*boxxsize
21004           yj=yj_safe+yshift*boxysize
21005           zj=zj_safe+zshift*boxzsize
21006           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21007           if(dist_temp.lt.dist_init) then
21008             dist_init=dist_temp
21009             xj_temp=xj
21010             yj_temp=yj
21011             zj_temp=zj
21012             isubchap=1
21013           endif
21014        enddo
21015        enddo
21016        enddo
21017        if (isubchap.eq.1) then
21018 !C          print *,i,j
21019           xj=xj_temp-xmedi
21020           yj=yj_temp-ymedi
21021           zj=zj_temp-zmedi
21022        else
21023           xj=xj_safe-xmedi
21024           yj=yj_safe-ymedi
21025           zj=zj_safe-zmedi
21026        endif
21027
21028           rij=xj*xj+yj*yj+zj*zj
21029 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21030           fac=(r0pp**2/rij)**3
21031           ev1=epspp*fac*fac
21032           ev2=epspp*fac
21033           evdw1ij=ev1-2*ev2
21034           fac=(-ev1-evdw1ij)/rij
21035 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21036           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21037           evdw1=evdw1+evdw1ij
21038 !C
21039 !C Calculate contributions to the Cartesian gradient.
21040 !C
21041           ggg(1)=fac*xj
21042           ggg(2)=fac*yj
21043           ggg(3)=fac*zj
21044           do k=1,3
21045             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21046             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21047           enddo
21048 !c phoshate-phosphate electrostatic interactions
21049           rij=dsqrt(rij)
21050           fac=1.0d0/rij
21051           eesij=dexp(-BEES*rij)*fac
21052 !          write (2,*)"fac",fac," eesijpp",eesij
21053           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21054           ees=ees+eesij
21055 !c          fac=-eesij*fac
21056           fac=-(fac+BEES)*eesij*fac
21057           ggg(1)=fac*xj
21058           ggg(2)=fac*yj
21059           ggg(3)=fac*zj
21060 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21061 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21062 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21063           do k=1,3
21064             gelpp(k,i)=gelpp(k,i)-ggg(k)
21065             gelpp(k,j)=gelpp(k,j)+ggg(k)
21066           enddo
21067         enddo ! j
21068       enddo   ! i
21069 !c      ees=332.0d0*ees
21070       ees=AEES*ees
21071       do i=nnt,nct
21072 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21073         do k=1,3
21074           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21075 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21076           gelpp(k,i)=AEES*gelpp(k,i)
21077         enddo
21078 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21079       enddo
21080 !c      write (2,*) "total EES",ees
21081       return
21082       end subroutine epp_nucl_sub
21083 !---------------------------------------------------------------------
21084       subroutine epsb(evdwpsb,eelpsb)
21085 !      use comm_locel
21086 !C
21087 !C This subroutine calculates the excluded-volume interaction energy between
21088 !C peptide-group centers and side chains and its gradient in virtual-bond and
21089 !C side-chain vectors.
21090 !C
21091       real(kind=8),dimension(3):: ggg
21092       integer :: i,iint,j,k,iteli,itypj,subchap
21093       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21094                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21095       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21096                     dist_temp, dist_init
21097       integer xshift,yshift,zshift
21098
21099 !cd    print '(a)','Enter ESCP'
21100 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21101       eelpsb=0.0d0
21102       evdwpsb=0.0d0
21103 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21104       do i=iatscp_s_nucl,iatscp_e_nucl
21105         if (itype(i,2).eq.ntyp1_molec(2) &
21106          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21107         xi=0.5D0*(c(1,i)+c(1,i+1))
21108         yi=0.5D0*(c(2,i)+c(2,i+1))
21109         zi=0.5D0*(c(3,i)+c(3,i+1))
21110           xi=mod(xi,boxxsize)
21111           if (xi.lt.0) xi=xi+boxxsize
21112           yi=mod(yi,boxysize)
21113           if (yi.lt.0) yi=yi+boxysize
21114           zi=mod(zi,boxzsize)
21115           if (zi.lt.0) zi=zi+boxzsize
21116
21117         do iint=1,nscp_gr_nucl(i)
21118
21119         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21120           itypj=itype(j,2)
21121           if (itypj.eq.ntyp1_molec(2)) cycle
21122 !C Uncomment following three lines for SC-p interactions
21123 !c         xj=c(1,nres+j)-xi
21124 !c         yj=c(2,nres+j)-yi
21125 !c         zj=c(3,nres+j)-zi
21126 !C Uncomment following three lines for Ca-p interactions
21127 !          xj=c(1,j)-xi
21128 !          yj=c(2,j)-yi
21129 !          zj=c(3,j)-zi
21130           xj=c(1,j)
21131           yj=c(2,j)
21132           zj=c(3,j)
21133           xj=mod(xj,boxxsize)
21134           if (xj.lt.0) xj=xj+boxxsize
21135           yj=mod(yj,boxysize)
21136           if (yj.lt.0) yj=yj+boxysize
21137           zj=mod(zj,boxzsize)
21138           if (zj.lt.0) zj=zj+boxzsize
21139       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21140       xj_safe=xj
21141       yj_safe=yj
21142       zj_safe=zj
21143       subchap=0
21144       do xshift=-1,1
21145       do yshift=-1,1
21146       do zshift=-1,1
21147           xj=xj_safe+xshift*boxxsize
21148           yj=yj_safe+yshift*boxysize
21149           zj=zj_safe+zshift*boxzsize
21150           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21151           if(dist_temp.lt.dist_init) then
21152             dist_init=dist_temp
21153             xj_temp=xj
21154             yj_temp=yj
21155             zj_temp=zj
21156             subchap=1
21157           endif
21158        enddo
21159        enddo
21160        enddo
21161        if (subchap.eq.1) then
21162           xj=xj_temp-xi
21163           yj=yj_temp-yi
21164           zj=zj_temp-zi
21165        else
21166           xj=xj_safe-xi
21167           yj=yj_safe-yi
21168           zj=zj_safe-zi
21169        endif
21170
21171           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21172           fac=rrij**expon2
21173           e1=fac*fac*aad_nucl(itypj)
21174           e2=fac*bad_nucl(itypj)
21175           if (iabs(j-i) .le. 2) then
21176             e1=scal14*e1
21177             e2=scal14*e2
21178           endif
21179           evdwij=e1+e2
21180           evdwpsb=evdwpsb+evdwij
21181           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21182              'evdw2',i,j,evdwij,"tu4"
21183 !C
21184 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21185 !C
21186           fac=-(evdwij+e1)*rrij
21187           ggg(1)=xj*fac
21188           ggg(2)=yj*fac
21189           ggg(3)=zj*fac
21190           do k=1,3
21191             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21192             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21193           enddo
21194         enddo
21195
21196         enddo ! iint
21197       enddo ! i
21198       do i=1,nct
21199         do j=1,3
21200           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21201           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21202         enddo
21203       enddo
21204       return
21205       end subroutine epsb
21206
21207 !------------------------------------------------------
21208       subroutine esb_gb(evdwsb,eelsb)
21209       use comm_locel
21210       use calc_data_nucl
21211       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21212       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21213       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21214       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21215                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21216       integer :: ii
21217       logical lprn
21218       evdw=0.0D0
21219       eelsb=0.0d0
21220       ecorr=0.0d0
21221       evdwsb=0.0D0
21222       lprn=.false.
21223       ind=0
21224 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21225       do i=iatsc_s_nucl,iatsc_e_nucl
21226         num_conti=0
21227         num_conti2=0
21228         itypi=itype(i,2)
21229 !        PRINT *,"I=",i,itypi
21230         if (itypi.eq.ntyp1_molec(2)) cycle
21231         itypi1=itype(i+1,2)
21232         xi=c(1,nres+i)
21233         yi=c(2,nres+i)
21234         zi=c(3,nres+i)
21235           xi=dmod(xi,boxxsize)
21236           if (xi.lt.0) xi=xi+boxxsize
21237           yi=dmod(yi,boxysize)
21238           if (yi.lt.0) yi=yi+boxysize
21239           zi=dmod(zi,boxzsize)
21240           if (zi.lt.0) zi=zi+boxzsize
21241
21242         dxi=dc_norm(1,nres+i)
21243         dyi=dc_norm(2,nres+i)
21244         dzi=dc_norm(3,nres+i)
21245         dsci_inv=vbld_inv(i+nres)
21246 !C
21247 !C Calculate SC interaction energy.
21248 !C
21249         do iint=1,nint_gr_nucl(i)
21250 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21251           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21252             ind=ind+1
21253 !            print *,"JESTEM"
21254             itypj=itype(j,2)
21255             if (itypj.eq.ntyp1_molec(2)) cycle
21256             dscj_inv=vbld_inv(j+nres)
21257             sig0ij=sigma_nucl(itypi,itypj)
21258             chi1=chi_nucl(itypi,itypj)
21259             chi2=chi_nucl(itypj,itypi)
21260             chi12=chi1*chi2
21261             chip1=chip_nucl(itypi,itypj)
21262             chip2=chip_nucl(itypj,itypi)
21263             chip12=chip1*chip2
21264 !            xj=c(1,nres+j)-xi
21265 !            yj=c(2,nres+j)-yi
21266 !            zj=c(3,nres+j)-zi
21267            xj=c(1,nres+j)
21268            yj=c(2,nres+j)
21269            zj=c(3,nres+j)
21270           xj=dmod(xj,boxxsize)
21271           if (xj.lt.0) xj=xj+boxxsize
21272           yj=dmod(yj,boxysize)
21273           if (yj.lt.0) yj=yj+boxysize
21274           zj=dmod(zj,boxzsize)
21275           if (zj.lt.0) zj=zj+boxzsize
21276       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21277       xj_safe=xj
21278       yj_safe=yj
21279       zj_safe=zj
21280       subchap=0
21281       do xshift=-1,1
21282       do yshift=-1,1
21283       do zshift=-1,1
21284           xj=xj_safe+xshift*boxxsize
21285           yj=yj_safe+yshift*boxysize
21286           zj=zj_safe+zshift*boxzsize
21287           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21288           if(dist_temp.lt.dist_init) then
21289             dist_init=dist_temp
21290             xj_temp=xj
21291             yj_temp=yj
21292             zj_temp=zj
21293             subchap=1
21294           endif
21295        enddo
21296        enddo
21297        enddo
21298        if (subchap.eq.1) then
21299           xj=xj_temp-xi
21300           yj=yj_temp-yi
21301           zj=zj_temp-zi
21302        else
21303           xj=xj_safe-xi
21304           yj=yj_safe-yi
21305           zj=zj_safe-zi
21306        endif
21307
21308             dxj=dc_norm(1,nres+j)
21309             dyj=dc_norm(2,nres+j)
21310             dzj=dc_norm(3,nres+j)
21311             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21312             rij=dsqrt(rrij)
21313 !C Calculate angle-dependent terms of energy and contributions to their
21314 !C derivatives.
21315             erij(1)=xj*rij
21316             erij(2)=yj*rij
21317             erij(3)=zj*rij
21318             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21319             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21320             om12=dxi*dxj+dyi*dyj+dzi*dzj
21321             call sc_angular_nucl
21322             sigsq=1.0D0/sigsq
21323             sig=sig0ij*dsqrt(sigsq)
21324             rij_shift=1.0D0/rij-sig+sig0ij
21325 !            print *,rij_shift,"rij_shift"
21326 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21327 !c     &       " rij_shift",rij_shift
21328             if (rij_shift.le.0.0D0) then
21329               evdw=1.0D20
21330               return
21331             endif
21332             sigder=-sig*sigsq
21333 !c---------------------------------------------------------------
21334             rij_shift=1.0D0/rij_shift
21335             fac=rij_shift**expon
21336             e1=fac*fac*aa_nucl(itypi,itypj)
21337             e2=fac*bb_nucl(itypi,itypj)
21338             evdwij=eps1*eps2rt*(e1+e2)
21339 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21340 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21341             eps2der=evdwij
21342             evdwij=evdwij*eps2rt
21343             evdwsb=evdwsb+evdwij
21344             if (lprn) then
21345             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21346             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21347             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21348              restyp(itypi,2),i,restyp(itypj,2),j, &
21349              epsi,sigm,chi1,chi2,chip1,chip2, &
21350              eps1,eps2rt**2,sig,sig0ij, &
21351              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21352             evdwij
21353             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21354             endif
21355
21356             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21357                              'evdw',i,j,evdwij,"tu3"
21358
21359
21360 !C Calculate gradient components.
21361             e1=e1*eps1*eps2rt**2
21362             fac=-expon*(e1+evdwij)*rij_shift
21363             sigder=fac*sigder
21364             fac=rij*fac
21365 !c            fac=0.0d0
21366 !C Calculate the radial part of the gradient
21367             gg(1)=xj*fac
21368             gg(2)=yj*fac
21369             gg(3)=zj*fac
21370 !C Calculate angular part of the gradient.
21371             call sc_grad_nucl
21372             call eelsbij(eelij,num_conti2)
21373             if (energy_dec .and. &
21374            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21375           write (istat,'(e14.5)') evdwij
21376             eelsb=eelsb+eelij
21377           enddo      ! j
21378         enddo        ! iint
21379         num_cont_hb(i)=num_conti2
21380       enddo          ! i
21381 !c      write (iout,*) "Number of loop steps in EGB:",ind
21382 !cccc      energy_dec=.false.
21383       return
21384       end subroutine esb_gb
21385 !-------------------------------------------------------------------------------
21386       subroutine eelsbij(eesij,num_conti2)
21387       use comm_locel
21388       use calc_data_nucl
21389       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21390       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21391       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21392                     dist_temp, dist_init,rlocshield,fracinbuf
21393       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21394
21395 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21396       real(kind=8) scal_el /0.5d0/
21397       integer :: iteli,itelj,kkk,kkll,m,isubchap
21398       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21399       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21400       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21401                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21402                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21403                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21404                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21405                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21406                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21407                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21408       ind=ind+1
21409       itypi=itype(i,2)
21410       itypj=itype(j,2)
21411 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21412       ael6i=ael6_nucl(itypi,itypj)
21413       ael3i=ael3_nucl(itypi,itypj)
21414       ael63i=ael63_nucl(itypi,itypj)
21415       ael32i=ael32_nucl(itypi,itypj)
21416 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21417 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21418       dxj=dc(1,j+nres)
21419       dyj=dc(2,j+nres)
21420       dzj=dc(3,j+nres)
21421       dx_normi=dc_norm(1,i+nres)
21422       dy_normi=dc_norm(2,i+nres)
21423       dz_normi=dc_norm(3,i+nres)
21424       dx_normj=dc_norm(1,j+nres)
21425       dy_normj=dc_norm(2,j+nres)
21426       dz_normj=dc_norm(3,j+nres)
21427 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21428 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21429 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21430       if (ipot_nucl.ne.2) then
21431         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21432         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21433         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21434       else
21435         cosa=om12
21436         cosb=om1
21437         cosg=om2
21438       endif
21439       r3ij=rij*rrij
21440       r6ij=r3ij*r3ij
21441       fac=cosa-3.0D0*cosb*cosg
21442       facfac=fac*fac
21443       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21444       fac3=ael6i*r6ij
21445       fac4=ael3i*r3ij
21446       fac5=ael63i*r6ij
21447       fac6=ael32i*r6ij
21448 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21449 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21450       el1=fac3*(4.0D0+facfac-fac1)
21451       el2=fac4*fac
21452       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21453       el4=fac6*facfac
21454       eesij=el1+el2+el3+el4
21455 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21456       ees0ij=4.0D0+facfac-fac1
21457
21458       if (energy_dec) then
21459           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21460           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21461            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21462            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21463            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21464           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21465       endif
21466
21467 !C
21468 !C Calculate contributions to the Cartesian gradient.
21469 !C
21470       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21471       fac1=fac
21472 !c      erij(1)=xj*rmij
21473 !c      erij(2)=yj*rmij
21474 !c      erij(3)=zj*rmij
21475 !*
21476 !* Radial derivatives. First process both termini of the fragment (i,j)
21477 !*
21478       ggg(1)=facel*xj
21479       ggg(2)=facel*yj
21480       ggg(3)=facel*zj
21481       do k=1,3
21482         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21483         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21484         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21485         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21486       enddo
21487 !*
21488 !* Angular part
21489 !*
21490       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21491       fac4=-3.0D0*fac4
21492       fac3=-6.0D0*fac3
21493       fac5= 6.0d0*fac5
21494       fac6=-6.0d0*fac6
21495       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21496        fac6*fac1*cosg
21497       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21498        fac6*fac1*cosb
21499       do k=1,3
21500         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21501         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21502       enddo
21503       do k=1,3
21504         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21505       enddo
21506       do k=1,3
21507         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21508              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21509              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21510         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21511              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21512              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21513         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21514         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21515       enddo
21516 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21517        IF ( j.gt.i+1 .and.&
21518           num_conti.le.maxcont) THEN
21519 !C
21520 !C Calculate the contact function. The ith column of the array JCONT will
21521 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21522 !C greater than I). The arrays FACONT and GACONT will contain the values of
21523 !C the contact function and its derivative.
21524         r0ij=2.20D0*sigma_nucl(itypi,itypj)
21525 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21526         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21527 !c        write (2,*) "fcont",fcont
21528         if (fcont.gt.0.0D0) then
21529           num_conti=num_conti+1
21530           num_conti2=num_conti2+1
21531
21532           if (num_conti.gt.maxconts) then
21533             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21534                           ' will skip next contacts for this conf.',maxconts
21535           else
21536             jcont_hb(num_conti,i)=j
21537 !c            write (iout,*) "num_conti",num_conti,
21538 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21539 !C Calculate contact energies
21540             cosa4=4.0D0*cosa
21541             wij=cosa-3.0D0*cosb*cosg
21542             cosbg1=cosb+cosg
21543             cosbg2=cosb-cosg
21544             fac3=dsqrt(-ael6i)*r3ij
21545 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21546             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21547             if (ees0tmp.gt.0) then
21548               ees0pij=dsqrt(ees0tmp)
21549             else
21550               ees0pij=0
21551             endif
21552             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21553             if (ees0tmp.gt.0) then
21554               ees0mij=dsqrt(ees0tmp)
21555             else
21556               ees0mij=0
21557             endif
21558             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21559             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21560 !c            write (iout,*) "i",i," j",j,
21561 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21562             ees0pij1=fac3/ees0pij
21563             ees0mij1=fac3/ees0mij
21564             fac3p=-3.0D0*fac3*rrij
21565             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21566             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21567             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21568             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21569             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21570             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21571             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21572             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21573             ecosap=ecosa1+ecosa2
21574             ecosbp=ecosb1+ecosb2
21575             ecosgp=ecosg1+ecosg2
21576             ecosam=ecosa1-ecosa2
21577             ecosbm=ecosb1-ecosb2
21578             ecosgm=ecosg1-ecosg2
21579 !C End diagnostics
21580             facont_hb(num_conti,i)=fcont
21581             fprimcont=fprimcont/rij
21582             do k=1,3
21583               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21584               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21585             enddo
21586             gggp(1)=gggp(1)+ees0pijp*xj
21587             gggp(2)=gggp(2)+ees0pijp*yj
21588             gggp(3)=gggp(3)+ees0pijp*zj
21589             gggm(1)=gggm(1)+ees0mijp*xj
21590             gggm(2)=gggm(2)+ees0mijp*yj
21591             gggm(3)=gggm(3)+ees0mijp*zj
21592 !C Derivatives due to the contact function
21593             gacont_hbr(1,num_conti,i)=fprimcont*xj
21594             gacont_hbr(2,num_conti,i)=fprimcont*yj
21595             gacont_hbr(3,num_conti,i)=fprimcont*zj
21596             do k=1,3
21597 !c
21598 !c Gradient of the correlation terms
21599 !c
21600               gacontp_hb1(k,num_conti,i)= &
21601              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21602             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21603               gacontp_hb2(k,num_conti,i)= &
21604              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21605             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21606               gacontp_hb3(k,num_conti,i)=gggp(k)
21607               gacontm_hb1(k,num_conti,i)= &
21608              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21609             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21610               gacontm_hb2(k,num_conti,i)= &
21611              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21612             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21613               gacontm_hb3(k,num_conti,i)=gggm(k)
21614             enddo
21615           endif
21616         endif
21617       ENDIF
21618       return
21619       end subroutine eelsbij
21620 !------------------------------------------------------------------
21621       subroutine sc_grad_nucl
21622       use comm_locel
21623       use calc_data_nucl
21624       real(kind=8),dimension(3) :: dcosom1,dcosom2
21625       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21626       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21627       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21628       do k=1,3
21629         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21630         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21631       enddo
21632       do k=1,3
21633         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21634       enddo
21635       do k=1,3
21636         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21637                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21638                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21639         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21640                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21641                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21642       enddo
21643 !C
21644 !C Calculate the components of the gradient in DC and X
21645 !C
21646       do l=1,3
21647         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21648         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21649       enddo
21650       return
21651       end subroutine sc_grad_nucl
21652 !-----------------------------------------------------------------------
21653       subroutine esb(esbloc)
21654 !C Calculate the local energy of a side chain and its derivatives in the
21655 !C corresponding virtual-bond valence angles THETA and the spherical angles
21656 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21657 !C added by Urszula Kozlowska. 07/11/2007
21658 !C
21659       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21660       real(kind=8),dimension(9):: x
21661      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21662       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21663       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21664       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21665        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21666        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21667        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21668        integer::it,nlobit,i,j,k
21669 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21670       delta=0.02d0*pi
21671       esbloc=0.0D0
21672       do i=loc_start_nucl,loc_end_nucl
21673         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21674         costtab(i+1) =dcos(theta(i+1))
21675         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21676         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21677         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21678         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21679         cosfac=dsqrt(cosfac2)
21680         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21681         sinfac=dsqrt(sinfac2)
21682         it=itype(i,2)
21683         if (it.eq.10) goto 1
21684
21685 !c
21686 !C  Compute the axes of tghe local cartesian coordinates system; store in
21687 !c   x_prime, y_prime and z_prime
21688 !c
21689         do j=1,3
21690           x_prime(j) = 0.00
21691           y_prime(j) = 0.00
21692           z_prime(j) = 0.00
21693         enddo
21694 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21695 !C     &   dc_norm(3,i+nres)
21696         do j = 1,3
21697           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21698           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21699         enddo
21700         do j = 1,3
21701           z_prime(j) = -uz(j,i-1)
21702 !           z_prime(j)=0.0
21703         enddo
21704
21705         xx=0.0d0
21706         yy=0.0d0
21707         zz=0.0d0
21708         do j = 1,3
21709           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21710           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21711           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21712         enddo
21713
21714         xxtab(i)=xx
21715         yytab(i)=yy
21716         zztab(i)=zz
21717          it=itype(i,2)
21718         do j = 1,9
21719           x(j) = sc_parmin_nucl(j,it)
21720         enddo
21721 #ifdef CHECK_COORD
21722 !Cc diagnostics - remove later
21723         xx1 = dcos(alph(2))
21724         yy1 = dsin(alph(2))*dcos(omeg(2))
21725         zz1 = -dsin(alph(2))*dsin(omeg(2))
21726         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21727          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21728          xx1,yy1,zz1
21729 !C,"  --- ", xx_w,yy_w,zz_w
21730 !c end diagnostics
21731 #endif
21732         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21733         esbloc = esbloc + sumene
21734         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21735 !        print *,"enecomp",sumene,sumene2
21736 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21737 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21738 #ifdef DEBUG
21739         write (2,*) "x",(x(k),k=1,9)
21740 !C
21741 !C This section to check the numerical derivatives of the energy of ith side
21742 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21743 !C #define DEBUG in the code to turn it on.
21744 !C
21745         write (2,*) "sumene               =",sumene
21746         aincr=1.0d-7
21747         xxsave=xx
21748         xx=xx+aincr
21749         write (2,*) xx,yy,zz
21750         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21751         de_dxx_num=(sumenep-sumene)/aincr
21752         xx=xxsave
21753         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21754         yysave=yy
21755         yy=yy+aincr
21756         write (2,*) xx,yy,zz
21757         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21758         de_dyy_num=(sumenep-sumene)/aincr
21759         yy=yysave
21760         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21761         zzsave=zz
21762         zz=zz+aincr
21763         write (2,*) xx,yy,zz
21764         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21765         de_dzz_num=(sumenep-sumene)/aincr
21766         zz=zzsave
21767         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21768         costsave=cost2tab(i+1)
21769         sintsave=sint2tab(i+1)
21770         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21771         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21772         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21773         de_dt_num=(sumenep-sumene)/aincr
21774         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21775         cost2tab(i+1)=costsave
21776         sint2tab(i+1)=sintsave
21777 !C End of diagnostics section.
21778 #endif
21779 !C
21780 !C Compute the gradient of esc
21781 !C
21782         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21783         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21784         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21785         de_dtt=0.0d0
21786 #ifdef DEBUG
21787         write (2,*) "x",(x(k),k=1,9)
21788         write (2,*) "xx",xx," yy",yy," zz",zz
21789         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21790           " de_zz   ",de_zz," de_tt   ",de_tt
21791         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21792           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21793 #endif
21794 !C
21795        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21796        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21797        cosfac2xx=cosfac2*xx
21798        sinfac2yy=sinfac2*yy
21799        do k = 1,3
21800          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21801            vbld_inv(i+1)
21802          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21803            vbld_inv(i)
21804          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21805          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21806 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21807 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21808 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21809 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21810          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21811          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21812          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21813          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21814          dZZ_Ci1(k)=0.0d0
21815          dZZ_Ci(k)=0.0d0
21816          do j=1,3
21817            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21818            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21819          enddo
21820
21821          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21822          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21823          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21824 !c
21825          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21826          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21827        enddo
21828
21829        do k=1,3
21830          dXX_Ctab(k,i)=dXX_Ci(k)
21831          dXX_C1tab(k,i)=dXX_Ci1(k)
21832          dYY_Ctab(k,i)=dYY_Ci(k)
21833          dYY_C1tab(k,i)=dYY_Ci1(k)
21834          dZZ_Ctab(k,i)=dZZ_Ci(k)
21835          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21836          dXX_XYZtab(k,i)=dXX_XYZ(k)
21837          dYY_XYZtab(k,i)=dYY_XYZ(k)
21838          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21839        enddo
21840        do k = 1,3
21841 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21842 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21843 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21844 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21845 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21846 !c     &    dt_dci(k)
21847 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21848 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21849          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21850          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21851          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21852          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21853          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21854          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21855 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21856        enddo
21857 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21858 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21859
21860 !C to check gradient call subroutine check_grad
21861
21862     1 continue
21863       enddo
21864       return
21865       end subroutine esb
21866 !=-------------------------------------------------------
21867       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21868 !      implicit none
21869       real(kind=8),dimension(9):: x(9)
21870        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21871       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21872       integer i
21873 !c      write (2,*) "enesc"
21874 !c      write (2,*) "x",(x(i),i=1,9)
21875 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21876       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21877         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21878         + x(9)*yy*zz
21879       enesc_nucl=sumene
21880       return
21881       end function enesc_nucl
21882 !-----------------------------------------------------------------------------
21883       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21884 #ifdef MPI
21885       include 'mpif.h'
21886       integer,parameter :: max_cont=2000
21887       integer,parameter:: max_dim=2*(8*3+6)
21888       integer, parameter :: msglen1=max_cont*max_dim
21889       integer,parameter :: msglen2=2*msglen1
21890       integer source,CorrelType,CorrelID,Error
21891       real(kind=8) :: buffer(max_cont,max_dim)
21892       integer status(MPI_STATUS_SIZE)
21893       integer :: ierror,nbytes
21894 #endif
21895       real(kind=8),dimension(3):: gx(3),gx1(3)
21896       real(kind=8) :: time00
21897       logical lprn,ldone
21898       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21899       real(kind=8) ecorr,ecorr3
21900       integer :: n_corr,n_corr1,mm,msglen
21901 !C Set lprn=.true. for debugging
21902       lprn=.false.
21903       n_corr=0
21904       n_corr1=0
21905 #ifdef MPI
21906       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21907
21908       if (nfgtasks.le.1) goto 30
21909       if (lprn) then
21910         write (iout,'(a)') 'Contact function values:'
21911         do i=nnt,nct-1
21912           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21913          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21914          j=1,num_cont_hb(i))
21915         enddo
21916       endif
21917 !C Caution! Following code assumes that electrostatic interactions concerning
21918 !C a given atom are split among at most two processors!
21919       CorrelType=477
21920       CorrelID=fg_rank+1
21921       ldone=.false.
21922       do i=1,max_cont
21923         do j=1,max_dim
21924           buffer(i,j)=0.0D0
21925         enddo
21926       enddo
21927       mm=mod(fg_rank,2)
21928 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21929       if (mm) 20,20,10
21930    10 continue
21931 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21932       if (fg_rank.gt.0) then
21933 !C Send correlation contributions to the preceding processor
21934         msglen=msglen1
21935         nn=num_cont_hb(iatel_s_nucl)
21936         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21937 !c        write (*,*) 'The BUFFER array:'
21938 !c        do i=1,nn
21939 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21940 !c        enddo
21941         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21942           msglen=msglen2
21943           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21944 !C Clear the contacts of the atom passed to the neighboring processor
21945         nn=num_cont_hb(iatel_s_nucl+1)
21946 !c        do i=1,nn
21947 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21948 !c        enddo
21949             num_cont_hb(iatel_s_nucl)=0
21950         endif
21951 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21952 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21953 !cd   & ' msglen=',msglen
21954 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21955 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21956 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21957         time00=MPI_Wtime()
21958         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21959          CorrelType,FG_COMM,IERROR)
21960         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21961 !cd      write (iout,*) 'Processor ',fg_rank,
21962 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21963 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21964 !c        write (*,*) 'Processor ',fg_rank,
21965 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21966 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21967 !c        msglen=msglen1
21968       endif ! (fg_rank.gt.0)
21969       if (ldone) goto 30
21970       ldone=.true.
21971    20 continue
21972 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21973       if (fg_rank.lt.nfgtasks-1) then
21974 !C Receive correlation contributions from the next processor
21975         msglen=msglen1
21976         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21977 !cd      write (iout,*) 'Processor',fg_rank,
21978 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21979 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21980 !c        write (*,*) 'Processor',fg_rank,
21981 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21982 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21983         time00=MPI_Wtime()
21984         nbytes=-1
21985         do while (nbytes.le.0)
21986           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21987           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21988         enddo
21989 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21990         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21991          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21992         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21993 !c        write (*,*) 'Processor',fg_rank,
21994 !c     &' has received correlation contribution from processor',fg_rank+1,
21995 !c     & ' msglen=',msglen,' nbytes=',nbytes
21996 !c        write (*,*) 'The received BUFFER array:'
21997 !c        do i=1,max_cont
21998 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21999 !c        enddo
22000         if (msglen.eq.msglen1) then
22001           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22002         else if (msglen.eq.msglen2)  then
22003           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22004           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22005         else
22006           write (iout,*) &
22007       'ERROR!!!! message length changed while processing correlations.'
22008           write (*,*) &
22009       'ERROR!!!! message length changed while processing correlations.'
22010           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22011         endif ! msglen.eq.msglen1
22012       endif ! fg_rank.lt.nfgtasks-1
22013       if (ldone) goto 30
22014       ldone=.true.
22015       goto 10
22016    30 continue
22017 #endif
22018       if (lprn) then
22019         write (iout,'(a)') 'Contact function values:'
22020         do i=nnt_molec(2),nct_molec(2)-1
22021           write (iout,'(2i3,50(1x,i2,f5.2))') &
22022          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22023          j=1,num_cont_hb(i))
22024         enddo
22025       endif
22026       ecorr=0.0D0
22027       ecorr3=0.0d0
22028 !C Remove the loop below after debugging !!!
22029 !      do i=nnt_molec(2),nct_molec(2)
22030 !        do j=1,3
22031 !          gradcorr_nucl(j,i)=0.0D0
22032 !          gradxorr_nucl(j,i)=0.0D0
22033 !          gradcorr3_nucl(j,i)=0.0D0
22034 !          gradxorr3_nucl(j,i)=0.0D0
22035 !        enddo
22036 !      enddo
22037 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22038 !C Calculate the local-electrostatic correlation terms
22039       do i=iatsc_s_nucl,iatsc_e_nucl
22040         i1=i+1
22041         num_conti=num_cont_hb(i)
22042         num_conti1=num_cont_hb(i+1)
22043 !        print *,i,num_conti,num_conti1
22044         do jj=1,num_conti
22045           j=jcont_hb(jj,i)
22046           do kk=1,num_conti1
22047             j1=jcont_hb(kk,i1)
22048 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22049 !c     &         ' jj=',jj,' kk=',kk
22050             if (j1.eq.j+1 .or. j1.eq.j-1) then
22051 !C
22052 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22053 !C The system gains extra energy.
22054 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22055 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22056 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22057 !C
22058               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22059               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22060                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22061               n_corr=n_corr+1
22062             else if (j1.eq.j) then
22063 !C
22064 !C Contacts I-J and I-(J+1) occur simultaneously.
22065 !C The system loses extra energy.
22066 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22067 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22068 !C Need to implement full formulas 32 from Liwo et al., 1998.
22069 !C
22070 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22071 !c     &         ' jj=',jj,' kk=',kk
22072               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22073             endif
22074           enddo ! kk
22075           do kk=1,num_conti
22076             j1=jcont_hb(kk,i)
22077 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22078 !c     &         ' jj=',jj,' kk=',kk
22079             if (j1.eq.j+1) then
22080 !C Contacts I-J and (I+1)-J occur simultaneously.
22081 !C The system loses extra energy.
22082               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22083             endif ! j1==j+1
22084           enddo ! kk
22085         enddo ! jj
22086       enddo ! i
22087       return
22088       end subroutine multibody_hb_nucl
22089 !-----------------------------------------------------------
22090       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22091 !      implicit real*8 (a-h,o-z)
22092 !      include 'DIMENSIONS'
22093 !      include 'COMMON.IOUNITS'
22094 !      include 'COMMON.DERIV'
22095 !      include 'COMMON.INTERACT'
22096 !      include 'COMMON.CONTACTS'
22097       real(kind=8),dimension(3) :: gx,gx1
22098       logical :: lprn
22099 !el local variables
22100       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22101       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22102                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22103                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22104                    rlocshield
22105
22106       lprn=.false.
22107       eij=facont_hb(jj,i)
22108       ekl=facont_hb(kk,k)
22109       ees0pij=ees0p(jj,i)
22110       ees0pkl=ees0p(kk,k)
22111       ees0mij=ees0m(jj,i)
22112       ees0mkl=ees0m(kk,k)
22113       ekont=eij*ekl
22114       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22115 !      print *,"ehbcorr_nucl",ekont,ees
22116 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22117 !C Following 4 lines for diagnostics.
22118 !cd    ees0pkl=0.0D0
22119 !cd    ees0pij=1.0D0
22120 !cd    ees0mkl=0.0D0
22121 !cd    ees0mij=1.0D0
22122 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22123 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22124 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22125 !C Calculate the multi-body contribution to energy.
22126 !      ecorr_nucl=ecorr_nucl+ekont*ees
22127 !C Calculate multi-body contributions to the gradient.
22128       coeffpees0pij=coeffp*ees0pij
22129       coeffmees0mij=coeffm*ees0mij
22130       coeffpees0pkl=coeffp*ees0pkl
22131       coeffmees0mkl=coeffm*ees0mkl
22132       do ll=1,3
22133         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22134        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22135        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22136         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22137         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22138         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22139         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22140         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22141         coeffmees0mij*gacontm_hb1(ll,kk,k))
22142         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22143         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22144         coeffmees0mij*gacontm_hb2(ll,kk,k))
22145         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22146           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22147           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22148         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22149         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22150         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22151           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22152           coeffmees0mij*gacontm_hb3(ll,kk,k))
22153         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22154         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22155         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22156         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22157         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22158         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22159       enddo
22160       ehbcorr_nucl=ekont*ees
22161       return
22162       end function ehbcorr_nucl
22163 !-------------------------------------------------------------------------
22164
22165      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22166 !      implicit real*8 (a-h,o-z)
22167 !      include 'DIMENSIONS'
22168 !      include 'COMMON.IOUNITS'
22169 !      include 'COMMON.DERIV'
22170 !      include 'COMMON.INTERACT'
22171 !      include 'COMMON.CONTACTS'
22172       real(kind=8),dimension(3) :: gx,gx1
22173       logical :: lprn
22174 !el local variables
22175       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22176       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22177                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22178                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22179                    rlocshield
22180
22181       lprn=.false.
22182       eij=facont_hb(jj,i)
22183       ekl=facont_hb(kk,k)
22184       ees0pij=ees0p(jj,i)
22185       ees0pkl=ees0p(kk,k)
22186       ees0mij=ees0m(jj,i)
22187       ees0mkl=ees0m(kk,k)
22188       ekont=eij*ekl
22189       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22190 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22191 !C Following 4 lines for diagnostics.
22192 !cd    ees0pkl=0.0D0
22193 !cd    ees0pij=1.0D0
22194 !cd    ees0mkl=0.0D0
22195 !cd    ees0mij=1.0D0
22196 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22197 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22198 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22199 !C Calculate the multi-body contribution to energy.
22200 !      ecorr=ecorr+ekont*ees
22201 !C Calculate multi-body contributions to the gradient.
22202       coeffpees0pij=coeffp*ees0pij
22203       coeffmees0mij=coeffm*ees0mij
22204       coeffpees0pkl=coeffp*ees0pkl
22205       coeffmees0mkl=coeffm*ees0mkl
22206       do ll=1,3
22207         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22208        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22209        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22210         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22211         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22212         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22213         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22214         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22215         coeffmees0mij*gacontm_hb1(ll,kk,k))
22216         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22217         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22218         coeffmees0mij*gacontm_hb2(ll,kk,k))
22219         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22220           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22221           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22222         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22223         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22224         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22225           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22226           coeffmees0mij*gacontm_hb3(ll,kk,k))
22227         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22228         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22229         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22230         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22231         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22232         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22233       enddo
22234       ehbcorr3_nucl=ekont*ees
22235       return
22236       end function ehbcorr3_nucl
22237 #ifdef MPI
22238       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22239       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22240       real(kind=8):: buffer(dimen1,dimen2)
22241       num_kont=num_cont_hb(atom)
22242       do i=1,num_kont
22243         do k=1,8
22244           do j=1,3
22245             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22246           enddo ! j
22247         enddo ! k
22248         buffer(i,indx+25)=facont_hb(i,atom)
22249         buffer(i,indx+26)=ees0p(i,atom)
22250         buffer(i,indx+27)=ees0m(i,atom)
22251         buffer(i,indx+28)=d_cont(i,atom)
22252         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22253       enddo ! i
22254       buffer(1,indx+30)=dfloat(num_kont)
22255       return
22256       end subroutine pack_buffer
22257 !c------------------------------------------------------------------------------
22258       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22259       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22260       real(kind=8):: buffer(dimen1,dimen2)
22261 !      double precision zapas
22262 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22263 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22264 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22265 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22266       num_kont=buffer(1,indx+30)
22267       num_kont_old=num_cont_hb(atom)
22268       num_cont_hb(atom)=num_kont+num_kont_old
22269       do i=1,num_kont
22270         ii=i+num_kont_old
22271         do k=1,8
22272           do j=1,3
22273             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22274           enddo ! j
22275         enddo ! k
22276         facont_hb(ii,atom)=buffer(i,indx+25)
22277         ees0p(ii,atom)=buffer(i,indx+26)
22278         ees0m(ii,atom)=buffer(i,indx+27)
22279         d_cont(i,atom)=buffer(i,indx+28)
22280         jcont_hb(ii,atom)=buffer(i,indx+29)
22281       enddo ! i
22282       return
22283       end subroutine unpack_buffer
22284 !c------------------------------------------------------------------------------
22285 #endif
22286       subroutine ecatcat(ecationcation)
22287         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22288         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22289         r7,r4,ecationcation,k0,rcal
22290         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22291         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22292         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22293         gg,r
22294
22295         ecationcation=0.0d0
22296         if (nres_molec(5).eq.0) return
22297         rcat0=3.472
22298         epscalc=0.05
22299         r06 = rcat0**6
22300         r012 = r06**2
22301 !        k0 = 332.0*(2.0*2.0)/80.0
22302         itmp=0
22303
22304         do i=1,4
22305         itmp=itmp+nres_molec(i)
22306         enddo
22307 !        write(iout,*) "itmp",itmp
22308         do i=itmp+1,itmp+nres_molec(5)-1
22309
22310         xi=c(1,i)
22311         yi=c(2,i)
22312         zi=c(3,i)
22313 !        write (iout,*) i,"TUTUT",c(1,i)
22314           itypi=itype(i,5)
22315           xi=mod(xi,boxxsize)
22316           if (xi.lt.0) xi=xi+boxxsize
22317           yi=mod(yi,boxysize)
22318           if (yi.lt.0) yi=yi+boxysize
22319           zi=mod(zi,boxzsize)
22320           if (zi.lt.0) zi=zi+boxzsize
22321
22322           do j=i+1,itmp+nres_molec(5)
22323           itypj=itype(j,5)
22324 !          print *,i,j,itypi,itypj
22325           k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22326 !           print *,i,j,'catcat'
22327            xj=c(1,j)
22328            yj=c(2,j)
22329            zj=c(3,j)
22330           xj=dmod(xj,boxxsize)
22331           if (xj.lt.0) xj=xj+boxxsize
22332           yj=dmod(yj,boxysize)
22333           if (yj.lt.0) yj=yj+boxysize
22334           zj=dmod(zj,boxzsize)
22335           if (zj.lt.0) zj=zj+boxzsize
22336 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22337       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22338       xj_safe=xj
22339       yj_safe=yj
22340       zj_safe=zj
22341       subchap=0
22342       do xshift=-1,1
22343       do yshift=-1,1
22344       do zshift=-1,1
22345           xj=xj_safe+xshift*boxxsize
22346           yj=yj_safe+yshift*boxysize
22347           zj=zj_safe+zshift*boxzsize
22348           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22349           if(dist_temp.lt.dist_init) then
22350             dist_init=dist_temp
22351             xj_temp=xj
22352             yj_temp=yj
22353             zj_temp=zj
22354             subchap=1
22355           endif
22356        enddo
22357        enddo
22358        enddo
22359        if (subchap.eq.1) then
22360           xj=xj_temp-xi
22361           yj=yj_temp-yi
22362           zj=zj_temp-zi
22363        else
22364           xj=xj_safe-xi
22365           yj=yj_safe-yi
22366           zj=zj_safe-zi
22367        endif
22368        rcal =xj**2+yj**2+zj**2
22369         ract=sqrt(rcal)
22370 !        rcat0=3.472
22371 !        epscalc=0.05
22372 !        r06 = rcat0**6
22373 !        r012 = r06**2
22374 !        k0 = 332*(2*2)/80
22375         Evan1cat=epscalc*(r012/(rcal**6))
22376         Evan2cat=epscalc*2*(r06/(rcal**3))
22377         Eeleccat=k0/ract
22378         r7 = rcal**7
22379         r4 = rcal**4
22380         r(1)=xj
22381         r(2)=yj
22382         r(3)=zj
22383         do k=1,3
22384           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22385           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22386           dEeleccat(k)=-k0*r(k)/ract**3
22387         enddo
22388         do k=1,3
22389           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22390           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22391           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22392         enddo
22393         if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22394          r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22395 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22396         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22397        enddo
22398        enddo
22399        return
22400        end subroutine ecatcat
22401 !---------------------------------------------------------------------------
22402 ! new for K+
22403       subroutine ecats_prot_amber(evdw)
22404 !      subroutine ecat_prot2(ecation_prot)
22405       use calc_data
22406       use comm_momo
22407
22408       logical :: lprn
22409 !el local variables
22410       integer :: iint,itypi1,subchap,isel,itmp
22411       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22412       real(kind=8) :: evdw
22413       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22414                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22415                     sslipi,sslipj,faclip,alpha_sco
22416       integer :: ii
22417       real(kind=8) :: fracinbuf
22418       real (kind=8) :: escpho
22419       real (kind=8),dimension(4):: ener
22420       real(kind=8) :: b1,b2,egb
22421       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22422        Lambf,&
22423        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22424        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22425        federmaus,&
22426        d1i,d1j
22427 !       real(kind=8),dimension(3,2)::erhead_tail
22428 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22429       real(kind=8) ::  facd4, adler, Fgb, facd3
22430       integer troll,jj,istate
22431       real (kind=8) :: dcosom1(3),dcosom2(3)
22432
22433       evdw=0.0D0
22434       if (nres_molec(5).eq.0) return
22435       eps_out=80.0d0
22436 !      sss_ele_cut=1.0d0
22437
22438         itmp=0
22439         do i=1,4
22440         itmp=itmp+nres_molec(i)
22441         enddo
22442 !        go to 17
22443 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22444         do i=ibond_start,ibond_end
22445
22446 !        print *,"I am in EVDW",i
22447         itypi=iabs(itype(i,1))
22448
22449 !        if (i.ne.47) cycle
22450         if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22451         itypi1=iabs(itype(i+1,1))
22452         xi=c(1,nres+i)
22453         yi=c(2,nres+i)
22454         zi=c(3,nres+i)
22455           xi=dmod(xi,boxxsize)
22456           if (xi.lt.0) xi=xi+boxxsize
22457           yi=dmod(yi,boxysize)
22458           if (yi.lt.0) yi=yi+boxysize
22459           zi=dmod(zi,boxzsize)
22460           if (zi.lt.0) zi=zi+boxzsize
22461         dxi=dc_norm(1,nres+i)
22462         dyi=dc_norm(2,nres+i)
22463         dzi=dc_norm(3,nres+i)
22464         dsci_inv=vbld_inv(i+nres)
22465          do j=itmp+1,itmp+nres_molec(5)
22466
22467 ! Calculate SC interaction energy.
22468             itypj=iabs(itype(j,5))
22469             if ((itypj.eq.ntyp1)) cycle
22470              CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22471
22472             dscj_inv=0.0
22473            xj=c(1,j)
22474            yj=c(2,j)
22475            zj=c(3,j)
22476            xj=dmod(xj,boxxsize)
22477            if (xj.lt.0) xj=xj+boxxsize
22478            yj=dmod(yj,boxysize)
22479            if (yj.lt.0) yj=yj+boxysize
22480            zj=dmod(zj,boxzsize)
22481            if (zj.lt.0) zj=zj+boxzsize
22482           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22483           xj_safe=xj
22484           yj_safe=yj
22485           zj_safe=zj
22486           subchap=0
22487
22488           do xshift=-1,1
22489           do yshift=-1,1
22490           do zshift=-1,1
22491           xj=xj_safe+xshift*boxxsize
22492           yj=yj_safe+yshift*boxysize
22493           zj=zj_safe+zshift*boxzsize
22494           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22495           if(dist_temp.lt.dist_init) then
22496             dist_init=dist_temp
22497             xj_temp=xj
22498             yj_temp=yj
22499             zj_temp=zj
22500             subchap=1
22501           endif
22502           enddo
22503           enddo
22504           enddo
22505           if (subchap.eq.1) then
22506           xj=xj_temp-xi
22507           yj=yj_temp-yi
22508           zj=zj_temp-zi
22509           else
22510           xj=xj_safe-xi
22511           yj=yj_safe-yi
22512           zj=zj_safe-zi
22513           endif
22514
22515 !          dxj = dc_norm( 1, nres+j )
22516 !          dyj = dc_norm( 2, nres+j )
22517 !          dzj = dc_norm( 3, nres+j )
22518
22519           itypi = itype(i,1)
22520           itypj = itype(j,5)
22521 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22522 ! sampling performed with amber package
22523 !          alf1   = 0.0d0
22524 !          alf2   = 0.0d0
22525 !          alf12  = 0.0d0
22526 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22527           chi1 = chi1cat(itypi,itypj)
22528           chis1 = chis1cat(itypi,itypj)
22529           chip1 = chipp1cat(itypi,itypj)
22530 !          chi1=0.0d0
22531 !          chis1=0.0d0
22532 !          chip1=0.0d0
22533           chi2=0.0
22534           chip2=0.0
22535           chis2=0.0
22536 !          chis2 = chis(itypj,itypi)
22537           chis12 = chis1 * chis2
22538           sig1 = sigmap1cat(itypi,itypj)
22539 !          sig2 = sigmap2(itypi,itypj)
22540 ! alpha factors from Fcav/Gcav
22541           b1cav = alphasurcat(1,itypi,itypj)
22542           b2cav = alphasurcat(2,itypi,itypj)
22543           b3cav = alphasurcat(3,itypi,itypj)
22544           b4cav = alphasurcat(4,itypi,itypj)
22545
22546 ! used to determine whether we want to do quadrupole calculations
22547        eps_in = epsintabcat(itypi,itypj)
22548        if (eps_in.eq.0.0) eps_in=1.0
22549
22550        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22551 !       Rtail = 0.0d0
22552
22553        DO k = 1, 3
22554         ctail(k,1)=c(k,i+nres)
22555         ctail(k,2)=c(k,j)
22556        END DO
22557 !c! tail distances will be themselves usefull elswhere
22558 !c1 (in Gcav, for example)
22559        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22560        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22561        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22562        Rtail = dsqrt( &
22563           (Rtail_distance(1)*Rtail_distance(1)) &
22564         + (Rtail_distance(2)*Rtail_distance(2)) &
22565         + (Rtail_distance(3)*Rtail_distance(3)))
22566 ! tail location and distance calculations
22567 ! dhead1
22568        d1 = dheadcat(1, 1, itypi, itypj)
22569 !       d2 = dhead(2, 1, itypi, itypj)
22570        DO k = 1,3
22571 ! location of polar head is computed by taking hydrophobic centre
22572 ! and moving by a d1 * dc_norm vector
22573 ! see unres publications for very informative images
22574         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22575         chead(k,2) = c(k, j)
22576 ! distance
22577 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22578 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22579         Rhead_distance(k) = chead(k,2) - chead(k,1)
22580        END DO
22581 ! pitagoras (root of sum of squares)
22582        Rhead = dsqrt( &
22583           (Rhead_distance(1)*Rhead_distance(1)) &
22584         + (Rhead_distance(2)*Rhead_distance(2)) &
22585         + (Rhead_distance(3)*Rhead_distance(3)))
22586 !-------------------------------------------------------------------
22587 ! zero everything that should be zero'ed
22588        evdwij = 0.0d0
22589        ECL = 0.0d0
22590        Elj = 0.0d0
22591        Equad = 0.0d0
22592        Epol = 0.0d0
22593        Fcav=0.0d0
22594        eheadtail = 0.0d0
22595        dGCLdOM1 = 0.0d0
22596        dGCLdOM2 = 0.0d0
22597        dGCLdOM12 = 0.0d0
22598        dPOLdOM1 = 0.0d0
22599        dPOLdOM2 = 0.0d0
22600           Fcav = 0.0d0
22601           dFdR = 0.0d0
22602           dCAVdOM1  = 0.0d0
22603           dCAVdOM2  = 0.0d0
22604           dCAVdOM12 = 0.0d0
22605           dscj_inv = vbld_inv(j+nres)
22606 !          print *,i,j,dscj_inv,dsci_inv
22607 ! rij holds 1/(distance of Calpha atoms)
22608           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22609           rij  = dsqrt(rrij)
22610           CALL sc_angular
22611 ! this should be in elgrad_init but om's are calculated by sc_angular
22612 ! which in turn is used by older potentials
22613 ! om = omega, sqom = om^2
22614           sqom1  = om1 * om1
22615           sqom2  = om2 * om2
22616           sqom12 = om12 * om12
22617
22618 ! now we calculate EGB - Gey-Berne
22619 ! It will be summed up in evdwij and saved in evdw
22620           sigsq     = 1.0D0  / sigsq
22621           sig       = sig0ij * dsqrt(sigsq)
22622 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22623           rij_shift = Rtail - sig + sig0ij
22624           IF (rij_shift.le.0.0D0) THEN
22625            evdw = 1.0D20
22626            RETURN
22627           END IF
22628           sigder = -sig * sigsq
22629           rij_shift = 1.0D0 / rij_shift
22630           fac       = rij_shift**expon
22631           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22632 !          print *,"ADAM",aa_aq(itypi,itypj)
22633
22634 !          c1        = 0.0d0
22635           c2        = fac  * bb_aq_cat(itypi,itypj)
22636 !          c2        = 0.0d0
22637           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22638           eps2der   = eps3rt * evdwij
22639           eps3der   = eps2rt * evdwij
22640 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22641           evdwij    = eps2rt * eps3rt * evdwij
22642 !#ifdef TSCSC
22643 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22644 !           evdw_p = evdw_p + evdwij
22645 !          ELSE
22646 !           evdw_m = evdw_m + evdwij
22647 !          END IF
22648 !#else
22649           evdw = evdw  &
22650               + evdwij
22651 !#endif
22652           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22653           fac    = -expon * (c1 + evdwij) * rij_shift
22654           sigder = fac * sigder
22655 ! Calculate distance derivative
22656           gg(1) =  fac
22657           gg(2) =  fac
22658           gg(3) =  fac
22659
22660           fac = chis1 * sqom1 + chis2 * sqom2 &
22661           - 2.0d0 * chis12 * om1 * om2 * om12
22662           pom = 1.0d0 - chis1 * chis2 * sqom12
22663           Lambf = (1.0d0 - (fac / pom))
22664           Lambf = dsqrt(Lambf)
22665           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22666           Chif = Rtail * sparrow
22667           ChiLambf = Chif * Lambf
22668           eagle = dsqrt(ChiLambf)
22669           bat = ChiLambf ** 11.0d0
22670           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22671           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22672           botsq = bot * bot
22673           Fcav = top / bot
22674
22675        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22676        dbot = 12.0d0 * b4cav * bat * Lambf
22677        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22678
22679           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22680           dbot = 12.0d0 * b4cav * bat * Chif
22681           eagle = Lambf * pom
22682           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22683           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22684           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22685               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22686
22687           dFdL = ((dtop * bot - top * dbot) / botsq)
22688           dCAVdOM1  = dFdL * ( dFdOM1 )
22689           dCAVdOM2  = dFdL * ( dFdOM2 )
22690           dCAVdOM12 = dFdL * ( dFdOM12 )
22691
22692        DO k= 1, 3
22693         ertail(k) = Rtail_distance(k)/Rtail
22694        END DO
22695        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22696        erdxj = scalar( ertail(1), dC_norm(1,j) )
22697        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
22698        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22699        DO k = 1, 3
22700         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22701         gradpepcatx(k,i) = gradpepcatx(k,i) &
22702                   - (( dFdR + gg(k) ) * pom)
22703         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22704 !        gvdwx(k,j) = gvdwx(k,j)   &
22705 !                  + (( dFdR + gg(k) ) * pom)
22706         gradpepcat(k,i) = gradpepcat(k,i)  &
22707                   - (( dFdR + gg(k) ) * ertail(k))
22708         gradpepcat(k,j) = gradpepcat(k,j) &
22709                   + (( dFdR + gg(k) ) * ertail(k))
22710         gg(k) = 0.0d0
22711        ENDDO
22712 !c! Compute head-head and head-tail energies for each state
22713           isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
22714           IF (isel.eq.0) THEN
22715 !c! No charges - do nothing
22716            eheadtail = 0.0d0
22717
22718           ELSE IF (isel.eq.1) THEN
22719 !c! Nonpolar-charge interactions
22720           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22721             Qi=Qi*2
22722             Qij=Qij*2
22723            endif
22724           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22725             Qj=Qj*2
22726             Qij=Qij*2
22727            endif
22728
22729            CALL enq_cat(epol)
22730            eheadtail = epol
22731 !           eheadtail = 0.0d0
22732
22733           ELSE IF (isel.eq.3) THEN
22734 !c! Dipole-charge interactions
22735           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22736             Qi=Qi*2
22737             Qij=Qij*2
22738            endif
22739           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22740             Qj=Qj*2
22741             Qij=Qij*2
22742            endif
22743            write(iout,*) "KURWA0",d1
22744
22745            CALL edq_cat(ecl, elj, epol)
22746           eheadtail = ECL + elj + epol
22747 !           eheadtail = 0.0d0
22748
22749           ELSE IF ((isel.eq.2)) THEN
22750
22751 !c! Same charge-charge interaction ( +/+ or -/- )
22752           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22753             Qi=Qi*2
22754             Qij=Qij*2
22755            endif
22756           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22757             Qj=Qj*2
22758             Qij=Qij*2
22759            endif
22760
22761            CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
22762            eheadtail = ECL + Egb + Epol + Fisocav + Elj
22763 !           eheadtail = 0.0d0
22764
22765 !          ELSE IF ((isel.eq.2.and.  &
22766 !               iabs(Qi).eq.1).and. &
22767 !               nstate(itypi,itypj).ne.1) THEN
22768 !c! Different charge-charge interaction ( +/- or -/+ )
22769 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22770 !            Qi=Qi*2
22771 !            Qij=Qij*2
22772 !           endif
22773 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22774 !            Qj=Qj*2
22775 !            Qij=Qij*2
22776 !           endif
22777 !
22778 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
22779        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
22780         evdw = evdw  + Fcav + eheadtail
22781
22782        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22783         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22784         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22785         Equad,evdwij+Fcav+eheadtail,evdw
22786 !       evdw = evdw  + Fcav  + eheadtail
22787
22788 !        iF (nstate(itypi,itypj).eq.1) THEN
22789         CALL sc_grad_cat
22790 !       END IF
22791 !c!-------------------------------------------------------------------
22792 !c! NAPISY KONCOWE
22793          END DO   ! j
22794        END DO     ! i
22795 !c      write (iout,*) "Number of loop steps in EGB:",ind
22796 !c      energy_dec=.false.
22797 !              print *,"EVDW KURW",evdw,nres
22798 !!!        return
22799    17   continue
22800         do i=ibond_start,ibond_end
22801
22802 !        print *,"I am in EVDW",i
22803         itypi=10 ! the peptide group parameters are for glicine
22804
22805 !        if (i.ne.47) cycle
22806         if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
22807         itypi1=iabs(itype(i+1,1))
22808         xi=(c(1,i)+c(1,i+1))/2.0
22809         yi=(c(2,i)+c(2,i+1))/2.0
22810         zi=(c(3,i)+c(3,i+1))/2.0
22811           xi=dmod(xi,boxxsize)
22812           if (xi.lt.0) xi=xi+boxxsize
22813           yi=dmod(yi,boxysize)
22814           if (yi.lt.0) yi=yi+boxysize
22815           zi=dmod(zi,boxzsize)
22816           if (zi.lt.0) zi=zi+boxzsize
22817         dxi=dc_norm(1,i)
22818         dyi=dc_norm(2,i)
22819         dzi=dc_norm(3,i)
22820         dsci_inv=vbld_inv(i+1)/2.0
22821          do j=itmp+1,itmp+nres_molec(5)
22822
22823 ! Calculate SC interaction energy.
22824             itypj=iabs(itype(j,5))
22825             if ((itypj.eq.ntyp1)) cycle
22826              CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22827
22828             dscj_inv=0.0
22829            xj=c(1,j)
22830            yj=c(2,j)
22831            zj=c(3,j)
22832            xj=dmod(xj,boxxsize)
22833            if (xj.lt.0) xj=xj+boxxsize
22834            yj=dmod(yj,boxysize)
22835            if (yj.lt.0) yj=yj+boxysize
22836            zj=dmod(zj,boxzsize)
22837            if (zj.lt.0) zj=zj+boxzsize
22838           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22839           xj_safe=xj
22840           yj_safe=yj
22841           zj_safe=zj
22842           subchap=0
22843
22844           do xshift=-1,1
22845           do yshift=-1,1
22846           do zshift=-1,1
22847           xj=xj_safe+xshift*boxxsize
22848           yj=yj_safe+yshift*boxysize
22849           zj=zj_safe+zshift*boxzsize
22850           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22851           if(dist_temp.lt.dist_init) then
22852             dist_init=dist_temp
22853             xj_temp=xj
22854             yj_temp=yj
22855             zj_temp=zj
22856             subchap=1
22857           endif
22858           enddo
22859           enddo
22860           enddo
22861           if (subchap.eq.1) then
22862           xj=xj_temp-xi
22863           yj=yj_temp-yi
22864           zj=zj_temp-zi
22865           else
22866           xj=xj_safe-xi
22867           yj=yj_safe-yi
22868           zj=zj_safe-zi
22869           endif
22870
22871           dxj = 0.0d0! dc_norm( 1, nres+j )
22872           dyj = 0.0d0!dc_norm( 2, nres+j )
22873           dzj = 0.0d0! dc_norm( 3, nres+j )
22874
22875           itypi = 10
22876           itypj = itype(j,5)
22877 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22878 ! sampling performed with amber package
22879 !          alf1   = 0.0d0
22880 !          alf2   = 0.0d0
22881 !          alf12  = 0.0d0
22882 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22883           chi1 = chi1cat(itypi,itypj)
22884           chis1 = chis1cat(itypi,itypj)
22885           chip1 = chipp1cat(itypi,itypj)
22886 !          chi1=0.0d0
22887 !          chis1=0.0d0
22888 !          chip1=0.0d0
22889           chi2=0.0
22890           chip2=0.0
22891           chis2=0.0
22892 !          chis2 = chis(itypj,itypi)
22893           chis12 = chis1 * chis2
22894           sig1 = sigmap1cat(itypi,itypj)
22895 !          sig2 = sigmap2(itypi,itypj)
22896 ! alpha factors from Fcav/Gcav
22897           b1cav = alphasurcat(1,itypi,itypj)
22898           b2cav = alphasurcat(2,itypi,itypj)
22899           b3cav = alphasurcat(3,itypi,itypj)
22900           b4cav = alphasurcat(4,itypi,itypj)
22901
22902 ! used to determine whether we want to do quadrupole calculations
22903        eps_in = epsintabcat(itypi,itypj)
22904        if (eps_in.eq.0.0) eps_in=1.0
22905
22906        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22907 !       Rtail = 0.0d0
22908
22909        DO k = 1, 3
22910         ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
22911         ctail(k,2)=c(k,j)
22912        END DO
22913 !c! tail distances will be themselves usefull elswhere
22914 !c1 (in Gcav, for example)
22915        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22916        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22917        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22918        Rtail = dsqrt( &
22919           (Rtail_distance(1)*Rtail_distance(1)) &
22920         + (Rtail_distance(2)*Rtail_distance(2)) &
22921         + (Rtail_distance(3)*Rtail_distance(3)))
22922 ! tail location and distance calculations
22923 ! dhead1
22924        d1 = dheadcat(1, 1, itypi, itypj)
22925 !       print *,"d1",d1
22926 !       d1=0.0d0
22927 !       d2 = dhead(2, 1, itypi, itypj)
22928        DO k = 1,3
22929 ! location of polar head is computed by taking hydrophobic centre
22930 ! and moving by a d1 * dc_norm vector
22931 ! see unres publications for very informative images
22932         chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
22933         chead(k,2) = c(k, j)
22934 ! distance
22935 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22936 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22937         Rhead_distance(k) = chead(k,2) - chead(k,1)
22938        END DO
22939 ! pitagoras (root of sum of squares)
22940        Rhead = dsqrt( &
22941           (Rhead_distance(1)*Rhead_distance(1)) &
22942         + (Rhead_distance(2)*Rhead_distance(2)) &
22943         + (Rhead_distance(3)*Rhead_distance(3)))
22944 !-------------------------------------------------------------------
22945 ! zero everything that should be zero'ed
22946        evdwij = 0.0d0
22947        ECL = 0.0d0
22948        Elj = 0.0d0
22949        Equad = 0.0d0
22950        Epol = 0.0d0
22951        Fcav=0.0d0
22952        eheadtail = 0.0d0
22953        dGCLdOM1 = 0.0d0
22954        dGCLdOM2 = 0.0d0
22955        dGCLdOM12 = 0.0d0
22956        dPOLdOM1 = 0.0d0
22957        dPOLdOM2 = 0.0d0
22958           Fcav = 0.0d0
22959           dFdR = 0.0d0
22960           dCAVdOM1  = 0.0d0
22961           dCAVdOM2  = 0.0d0
22962           dCAVdOM12 = 0.0d0
22963           dscj_inv = vbld_inv(j+nres)
22964 !          print *,i,j,dscj_inv,dsci_inv
22965 ! rij holds 1/(distance of Calpha atoms)
22966           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22967           rij  = dsqrt(rrij)
22968           CALL sc_angular
22969 ! this should be in elgrad_init but om's are calculated by sc_angular
22970 ! which in turn is used by older potentials
22971 ! om = omega, sqom = om^2
22972           sqom1  = om1 * om1
22973           sqom2  = om2 * om2
22974           sqom12 = om12 * om12
22975
22976 ! now we calculate EGB - Gey-Berne
22977 ! It will be summed up in evdwij and saved in evdw
22978           sigsq     = 1.0D0  / sigsq
22979           sig       = sig0ij * dsqrt(sigsq)
22980 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22981           rij_shift = Rtail - sig + sig0ij
22982           IF (rij_shift.le.0.0D0) THEN
22983            evdw = 1.0D20
22984            RETURN
22985           END IF
22986           sigder = -sig * sigsq
22987           rij_shift = 1.0D0 / rij_shift
22988           fac       = rij_shift**expon
22989           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22990 !          print *,"ADAM",aa_aq(itypi,itypj)
22991
22992 !          c1        = 0.0d0
22993           c2        = fac  * bb_aq_cat(itypi,itypj)
22994 !          c2        = 0.0d0
22995           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22996           eps2der   = eps3rt * evdwij
22997           eps3der   = eps2rt * evdwij
22998 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22999           evdwij    = eps2rt * eps3rt * evdwij
23000 !#ifdef TSCSC
23001 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23002 !           evdw_p = evdw_p + evdwij
23003 !          ELSE
23004 !           evdw_m = evdw_m + evdwij
23005 !          END IF
23006 !#else
23007           evdw = evdw  &
23008               + evdwij
23009 !#endif
23010           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23011           fac    = -expon * (c1 + evdwij) * rij_shift
23012           sigder = fac * sigder
23013 ! Calculate distance derivative
23014           gg(1) =  fac
23015           gg(2) =  fac
23016           gg(3) =  fac
23017
23018           fac = chis1 * sqom1 + chis2 * sqom2 &
23019           - 2.0d0 * chis12 * om1 * om2 * om12
23020
23021           pom = 1.0d0 - chis1 * chis2 * sqom12
23022 !          print *,"TUT2",fac,chis1,sqom1,pom
23023           Lambf = (1.0d0 - (fac / pom))
23024           Lambf = dsqrt(Lambf)
23025           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23026           Chif = Rtail * sparrow
23027           ChiLambf = Chif * Lambf
23028           eagle = dsqrt(ChiLambf)
23029           bat = ChiLambf ** 11.0d0
23030           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23031           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23032           botsq = bot * bot
23033           Fcav = top / bot
23034
23035        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23036        dbot = 12.0d0 * b4cav * bat * Lambf
23037        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23038
23039           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23040           dbot = 12.0d0 * b4cav * bat * Chif
23041           eagle = Lambf * pom
23042           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23043           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23044           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23045               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23046
23047           dFdL = ((dtop * bot - top * dbot) / botsq)
23048           dCAVdOM1  = dFdL * ( dFdOM1 )
23049           dCAVdOM2  = dFdL * ( dFdOM2 )
23050           dCAVdOM12 = dFdL * ( dFdOM12 )
23051
23052        DO k= 1, 3
23053         ertail(k) = Rtail_distance(k)/Rtail
23054        END DO
23055        erdxi = scalar( ertail(1), dC_norm(1,i) )
23056        erdxj = scalar( ertail(1), dC_norm(1,j) )
23057        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
23058        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23059        DO k = 1, 3
23060         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
23061 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
23062 !                  - (( dFdR + gg(k) ) * pom)
23063         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23064 !        gvdwx(k,j) = gvdwx(k,j)   &
23065 !                  + (( dFdR + gg(k) ) * pom)
23066         gradpepcat(k,i) = gradpepcat(k,i)  &
23067                   - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23068         gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
23069                   - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23070
23071         gradpepcat(k,j) = gradpepcat(k,j) &
23072                   + (( dFdR + gg(k) ) * ertail(k))
23073         gg(k) = 0.0d0
23074        ENDDO
23075 !c! Compute head-head and head-tail energies for each state
23076           isel = 3
23077 !c! Dipole-charge interactions
23078           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23079             Qi=Qi*2
23080             Qij=Qij*2
23081            endif
23082           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23083             Qj=Qj*2
23084             Qij=Qij*2
23085            endif
23086            CALL edq_cat_pep(ecl, elj, epol)
23087            eheadtail = ECL + elj + epol
23088 !          print *,"i,",i,eheadtail
23089 !           eheadtail = 0.0d0
23090
23091         evdw = evdw  + Fcav + eheadtail
23092
23093        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23094         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23095         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23096         Equad,evdwij+Fcav+eheadtail,evdw
23097 !       evdw = evdw  + Fcav  + eheadtail
23098
23099 !        iF (nstate(itypi,itypj).eq.1) THEN
23100         CALL sc_grad_cat_pep
23101 !       END IF
23102 !c!-------------------------------------------------------------------
23103 !c! NAPISY KONCOWE
23104          END DO   ! j
23105        END DO     ! i
23106 !c      write (iout,*) "Number of loop steps in EGB:",ind
23107 !c      energy_dec=.false.
23108 !              print *,"EVDW KURW",evdw,nres
23109
23110
23111       return
23112       end subroutine ecats_prot_amber
23113
23114 !---------------------------------------------------------------------------
23115 ! old for Ca2+
23116        subroutine ecat_prot(ecation_prot)
23117 !      use calc_data
23118 !      use comm_momo
23119        integer i,j,k,subchap,itmp,inum
23120         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23121         r7,r4,ecationcation
23122         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23123         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23124         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23125         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23126         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23127         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23128         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23129         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23130         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23131         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23132         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23133         ndiv,ndivi
23134         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23135         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23136         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23137         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23138         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23139         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23140         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23141         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23142         dEvan1Cat
23143         real(kind=8),dimension(6) :: vcatprm
23144         ecation_prot=0.0d0
23145 ! first lets calculate interaction with peptide groups
23146         if (nres_molec(5).eq.0) return
23147         itmp=0
23148         do i=1,4
23149         itmp=itmp+nres_molec(i)
23150         enddo
23151 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23152         do i=ibond_start,ibond_end
23153 !         cycle
23154          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23155         xi=0.5d0*(c(1,i)+c(1,i+1))
23156         yi=0.5d0*(c(2,i)+c(2,i+1))
23157         zi=0.5d0*(c(3,i)+c(3,i+1))
23158           xi=mod(xi,boxxsize)
23159           if (xi.lt.0) xi=xi+boxxsize
23160           yi=mod(yi,boxysize)
23161           if (yi.lt.0) yi=yi+boxysize
23162           zi=mod(zi,boxzsize)
23163           if (zi.lt.0) zi=zi+boxzsize
23164
23165          do j=itmp+1,itmp+nres_molec(5)
23166 !           print *,"WTF",itmp,j,i
23167 ! all parameters were for Ca2+ to approximate single charge divide by two
23168          ndiv=1.0
23169          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23170          wconst=78*ndiv
23171         wdip =1.092777950857032D2
23172         wdip=wdip/wconst
23173         wmodquad=-2.174122713004870D4
23174         wmodquad=wmodquad/wconst
23175         wquad1 = 3.901232068562804D1
23176         wquad1=wquad1/wconst
23177         wquad2 = 3
23178         wquad2=wquad2/wconst
23179         wvan1 = 0.1
23180         wvan2 = 6
23181 !        itmp=0
23182
23183            xj=c(1,j)
23184            yj=c(2,j)
23185            zj=c(3,j)
23186           xj=dmod(xj,boxxsize)
23187           if (xj.lt.0) xj=xj+boxxsize
23188           yj=dmod(yj,boxysize)
23189           if (yj.lt.0) yj=yj+boxysize
23190           zj=dmod(zj,boxzsize)
23191           if (zj.lt.0) zj=zj+boxzsize
23192       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23193       xj_safe=xj
23194       yj_safe=yj
23195       zj_safe=zj
23196       subchap=0
23197       do xshift=-1,1
23198       do yshift=-1,1
23199       do zshift=-1,1
23200           xj=xj_safe+xshift*boxxsize
23201           yj=yj_safe+yshift*boxysize
23202           zj=zj_safe+zshift*boxzsize
23203           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23204           if(dist_temp.lt.dist_init) then
23205             dist_init=dist_temp
23206             xj_temp=xj
23207             yj_temp=yj
23208             zj_temp=zj
23209             subchap=1
23210           endif
23211        enddo
23212        enddo
23213        enddo
23214        if (subchap.eq.1) then
23215           xj=xj_temp-xi
23216           yj=yj_temp-yi
23217           zj=zj_temp-zi
23218        else
23219           xj=xj_safe-xi
23220           yj=yj_safe-yi
23221           zj=zj_safe-zi
23222        endif
23223 !       enddo
23224 !       enddo
23225        rcpm = sqrt(xj**2+yj**2+zj**2)
23226        drcp_norm(1)=xj/rcpm
23227        drcp_norm(2)=yj/rcpm
23228        drcp_norm(3)=zj/rcpm
23229        dcmag=0.0
23230        do k=1,3
23231        dcmag=dcmag+dc(k,i)**2
23232        enddo
23233        dcmag=dsqrt(dcmag)
23234        do k=1,3
23235          myd_norm(k)=dc(k,i)/dcmag
23236        enddo
23237         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23238         drcp_norm(3)*myd_norm(3)
23239         rsecp = rcpm**2
23240         Ir = 1.0d0/rcpm
23241         Irsecp = 1.0d0/rsecp
23242         Irthrp = Irsecp/rcpm
23243         Irfourp = Irthrp/rcpm
23244         Irfiftp = Irfourp/rcpm
23245         Irsistp=Irfiftp/rcpm
23246         Irseven=Irsistp/rcpm
23247         Irtwelv=Irsistp*Irsistp
23248         Irthir=Irtwelv/rcpm
23249         sin2thet = (1-costhet*costhet)
23250         sinthet=sqrt(sin2thet)
23251         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23252              *sin2thet
23253         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23254              2*wvan2**6*Irsistp)
23255         ecation_prot = ecation_prot+E1+E2
23256 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23257         dE1dr = -2*costhet*wdip*Irthrp-&
23258          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23259         dE2dr = 3*wquad1*wquad2*Irfourp-     &
23260           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23261         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23262         do k=1,3
23263           drdpep(k) = -drcp_norm(k)
23264           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23265           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23266           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23267           dEddci(k) = dEdcos*dcosddci(k)
23268         enddo
23269         do k=1,3
23270         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23271         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23272         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23273         enddo
23274        enddo ! j
23275        enddo ! i
23276 !------------------------------------------sidechains
23277 !        do i=1,nres_molec(1)
23278         do i=ibond_start,ibond_end
23279          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23280 !         cycle
23281 !        print *,i,ecation_prot
23282         xi=(c(1,i+nres))
23283         yi=(c(2,i+nres))
23284         zi=(c(3,i+nres))
23285           xi=mod(xi,boxxsize)
23286           if (xi.lt.0) xi=xi+boxxsize
23287           yi=mod(yi,boxysize)
23288           if (yi.lt.0) yi=yi+boxysize
23289           zi=mod(zi,boxzsize)
23290           if (zi.lt.0) zi=zi+boxzsize
23291           do k=1,3
23292             cm1(k)=dc(k,i+nres)
23293           enddo
23294            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23295          do j=itmp+1,itmp+nres_molec(5)
23296          ndiv=1.0
23297          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23298
23299            xj=c(1,j)
23300            yj=c(2,j)
23301            zj=c(3,j)
23302           xj=dmod(xj,boxxsize)
23303           if (xj.lt.0) xj=xj+boxxsize
23304           yj=dmod(yj,boxysize)
23305           if (yj.lt.0) yj=yj+boxysize
23306           zj=dmod(zj,boxzsize)
23307           if (zj.lt.0) zj=zj+boxzsize
23308       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23309       xj_safe=xj
23310       yj_safe=yj
23311       zj_safe=zj
23312       subchap=0
23313       do xshift=-1,1
23314       do yshift=-1,1
23315       do zshift=-1,1
23316           xj=xj_safe+xshift*boxxsize
23317           yj=yj_safe+yshift*boxysize
23318           zj=zj_safe+zshift*boxzsize
23319           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23320           if(dist_temp.lt.dist_init) then
23321             dist_init=dist_temp
23322             xj_temp=xj
23323             yj_temp=yj
23324             zj_temp=zj
23325             subchap=1
23326           endif
23327        enddo
23328        enddo
23329        enddo
23330        if (subchap.eq.1) then
23331           xj=xj_temp-xi
23332           yj=yj_temp-yi
23333           zj=zj_temp-zi
23334        else
23335           xj=xj_safe-xi
23336           yj=yj_safe-yi
23337           zj=zj_safe-zi
23338        endif
23339 !       enddo
23340 !       enddo
23341 ! 15- Glu 16-Asp
23342          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23343          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23344          (itype(i,1).eq.25))) then
23345             if(itype(i,1).eq.16) then
23346             inum=1
23347             else
23348             inum=2
23349             endif
23350             do k=1,6
23351             vcatprm(k)=catprm(k,inum)
23352             enddo
23353             dASGL=catprm(7,inum)
23354 !             do k=1,3
23355 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23356                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23357                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23358                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23359
23360 !                valpha(k)=c(k,i)
23361 !                vcat(k)=c(k,j)
23362                 if (subchap.eq.1) then
23363                  vcat(1)=xj_temp
23364                  vcat(2)=yj_temp
23365                  vcat(3)=zj_temp
23366                  else
23367                 vcat(1)=xj_safe
23368                 vcat(2)=yj_safe
23369                 vcat(3)=zj_safe
23370                  endif
23371                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23372                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23373                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23374
23375 !              enddo
23376         do k=1,3
23377           dx(k) = vcat(k)-vcm(k)
23378         enddo
23379         do k=1,3
23380           v1(k)=(vcm(k)-valpha(k))
23381           v2(k)=(vcat(k)-valpha(k))
23382         enddo
23383         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23384         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23385         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23386
23387 !  The weights of the energy function calculated from
23388 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23389           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23390             ndivi=0.5
23391           else
23392             ndivi=1.0
23393           endif
23394          ndiv=1.0
23395          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23396
23397         wh2o=78*ndivi*ndiv
23398         wc = vcatprm(1)
23399         wc=wc/wh2o
23400         wdip =vcatprm(2)
23401         wdip=wdip/wh2o
23402         wquad1 =vcatprm(3)
23403         wquad1=wquad1/wh2o
23404         wquad2 = vcatprm(4)
23405         wquad2=wquad2/wh2o
23406         wquad2p = 1.0d0-wquad2
23407         wvan1 = vcatprm(5)
23408         wvan2 =vcatprm(6)
23409         opt = dx(1)**2+dx(2)**2
23410         rsecp = opt+dx(3)**2
23411         rs = sqrt(rsecp)
23412         rthrp = rsecp*rs
23413         rfourp = rthrp*rs
23414         rsixp = rfourp*rsecp
23415         reight=rsixp*rsecp
23416         Ir = 1.0d0/rs
23417         Irsecp = 1.0d0/rsecp
23418         Irthrp = Irsecp/rs
23419         Irfourp = Irthrp/rs
23420         Irsixp = 1.0d0/rsixp
23421         Ireight=1.0d0/reight
23422         Irtw=Irsixp*Irsixp
23423         Irthir=Irtw/rs
23424         Irfourt=Irthir/rs
23425         opt1 = (4*rs*dx(3)*wdip)
23426         opt2 = 6*rsecp*wquad1*opt
23427         opt3 = wquad1*wquad2p*Irsixp
23428         opt4 = (wvan1*wvan2**12)
23429         opt5 = opt4*12*Irfourt
23430         opt6 = 2*wvan1*wvan2**6
23431         opt7 = 6*opt6*Ireight
23432         opt8 = wdip/v1m
23433         opt10 = wdip/v2m
23434         opt11 = (rsecp*v2m)**2
23435         opt12 = (rsecp*v1m)**2
23436         opt14 = (v1m*v2m*rsecp)**2
23437         opt15 = -wquad1/v2m**2
23438         opt16 = (rthrp*(v1m*v2m)**2)**2
23439         opt17 = (v1m**2*rthrp)**2
23440         opt18 = -wquad1/rthrp
23441         opt19 = (v1m**2*v2m**2)**2
23442         Ec = wc*Ir
23443         do k=1,3
23444           dEcCat(k) = -(dx(k)*wc)*Irthrp
23445           dEcCm(k)=(dx(k)*wc)*Irthrp
23446           dEcCalp(k)=0.0d0
23447         enddo
23448         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23449         do k=1,3
23450           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23451                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23452           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23453                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23454           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23455                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23456                       *v1dpv2)/opt14
23457         enddo
23458         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23459         do k=1,3
23460           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23461                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23462                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23463           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23464                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23465                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23466           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23467                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23468                         v1dpv2**2)/opt19
23469         enddo
23470         Equad2=wquad1*wquad2p*Irthrp
23471         do k=1,3
23472           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23473           dEquad2Cm(k)=3*dx(k)*rs*opt3
23474           dEquad2Calp(k)=0.0d0
23475         enddo
23476         Evan1=opt4*Irtw
23477         do k=1,3
23478           dEvan1Cat(k)=-dx(k)*opt5
23479           dEvan1Cm(k)=dx(k)*opt5
23480           dEvan1Calp(k)=0.0d0
23481         enddo
23482         Evan2=-opt6*Irsixp
23483         do k=1,3
23484           dEvan2Cat(k)=dx(k)*opt7
23485           dEvan2Cm(k)=-dx(k)*opt7
23486           dEvan2Calp(k)=0.0d0
23487         enddo
23488         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23489 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23490
23491         do k=1,3
23492           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23493                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23494 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23495           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23496                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23497           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23498                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23499         enddo
23500             dscmag = 0.0d0
23501             do k=1,3
23502               dscvec(k) = dc(k,i+nres)
23503               dscmag = dscmag+dscvec(k)*dscvec(k)
23504             enddo
23505             dscmag3 = dscmag
23506             dscmag = sqrt(dscmag)
23507             dscmag3 = dscmag3*dscmag
23508             constA = 1.0d0+dASGL/dscmag
23509             constB = 0.0d0
23510             do k=1,3
23511               constB = constB+dscvec(k)*dEtotalCm(k)
23512             enddo
23513             constB = constB*dASGL/dscmag3
23514             do k=1,3
23515               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23516               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23517                constA*dEtotalCm(k)-constB*dscvec(k)
23518 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23519               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23520               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23521              enddo
23522         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23523            if(itype(i,1).eq.14) then
23524             inum=3
23525             else
23526             inum=4
23527             endif
23528             do k=1,6
23529             vcatprm(k)=catprm(k,inum)
23530             enddo
23531             dASGL=catprm(7,inum)
23532 !             do k=1,3
23533 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23534 !                valpha(k)=c(k,i)
23535 !                vcat(k)=c(k,j)
23536 !              enddo
23537                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23538                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23539                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23540                 if (subchap.eq.1) then
23541                  vcat(1)=xj_temp
23542                  vcat(2)=yj_temp
23543                  vcat(3)=zj_temp
23544                  else
23545                 vcat(1)=xj_safe
23546                 vcat(2)=yj_safe
23547                 vcat(3)=zj_safe
23548                 endif
23549                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23550                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23551                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23552
23553
23554         do k=1,3
23555           dx(k) = vcat(k)-vcm(k)
23556         enddo
23557         do k=1,3
23558           v1(k)=(vcm(k)-valpha(k))
23559           v2(k)=(vcat(k)-valpha(k))
23560         enddo
23561         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23562         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23563         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23564 !  The weights of the energy function calculated from
23565 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23566          ndiv=1.0
23567          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23568
23569         wh2o=78*ndiv
23570         wdip =vcatprm(2)
23571         wdip=wdip/wh2o
23572         wquad1 =vcatprm(3)
23573         wquad1=wquad1/wh2o
23574         wquad2 = vcatprm(4)
23575         wquad2=wquad2/wh2o
23576         wquad2p = 1-wquad2
23577         wvan1 = vcatprm(5)
23578         wvan2 =vcatprm(6)
23579         opt = dx(1)**2+dx(2)**2
23580         rsecp = opt+dx(3)**2
23581         rs = sqrt(rsecp)
23582         rthrp = rsecp*rs
23583         rfourp = rthrp*rs
23584         rsixp = rfourp*rsecp
23585         reight=rsixp*rsecp
23586         Ir = 1.0d0/rs
23587         Irsecp = 1/rsecp
23588         Irthrp = Irsecp/rs
23589         Irfourp = Irthrp/rs
23590         Irsixp = 1/rsixp
23591         Ireight=1/reight
23592         Irtw=Irsixp*Irsixp
23593         Irthir=Irtw/rs
23594         Irfourt=Irthir/rs
23595         opt1 = (4*rs*dx(3)*wdip)
23596         opt2 = 6*rsecp*wquad1*opt
23597         opt3 = wquad1*wquad2p*Irsixp
23598         opt4 = (wvan1*wvan2**12)
23599         opt5 = opt4*12*Irfourt
23600         opt6 = 2*wvan1*wvan2**6
23601         opt7 = 6*opt6*Ireight
23602         opt8 = wdip/v1m
23603         opt10 = wdip/v2m
23604         opt11 = (rsecp*v2m)**2
23605         opt12 = (rsecp*v1m)**2
23606         opt14 = (v1m*v2m*rsecp)**2
23607         opt15 = -wquad1/v2m**2
23608         opt16 = (rthrp*(v1m*v2m)**2)**2
23609         opt17 = (v1m**2*rthrp)**2
23610         opt18 = -wquad1/rthrp
23611         opt19 = (v1m**2*v2m**2)**2
23612         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23613         do k=1,3
23614           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23615                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23616          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23617                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23618           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23619                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23620                       *v1dpv2)/opt14
23621         enddo
23622         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23623         do k=1,3
23624           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23625                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23626                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23627           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23628                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23629                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23630           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23631                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23632                         v1dpv2**2)/opt19
23633         enddo
23634         Equad2=wquad1*wquad2p*Irthrp
23635         do k=1,3
23636           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23637           dEquad2Cm(k)=3*dx(k)*rs*opt3
23638           dEquad2Calp(k)=0.0d0
23639         enddo
23640         Evan1=opt4*Irtw
23641         do k=1,3
23642           dEvan1Cat(k)=-dx(k)*opt5
23643           dEvan1Cm(k)=dx(k)*opt5
23644           dEvan1Calp(k)=0.0d0
23645         enddo
23646         Evan2=-opt6*Irsixp
23647         do k=1,3
23648           dEvan2Cat(k)=dx(k)*opt7
23649           dEvan2Cm(k)=-dx(k)*opt7
23650           dEvan2Calp(k)=0.0d0
23651         enddo
23652          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23653         do k=1,3
23654           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23655                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23656           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23657                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23658           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23659                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23660         enddo
23661             dscmag = 0.0d0
23662             do k=1,3
23663               dscvec(k) = c(k,i+nres)-c(k,i)
23664 ! TU SPRAWDZ???
23665 !              dscvec(1) = xj
23666 !              dscvec(2) = yj
23667 !              dscvec(3) = zj
23668
23669               dscmag = dscmag+dscvec(k)*dscvec(k)
23670             enddo
23671             dscmag3 = dscmag
23672             dscmag = sqrt(dscmag)
23673             dscmag3 = dscmag3*dscmag
23674             constA = 1+dASGL/dscmag
23675             constB = 0.0d0
23676             do k=1,3
23677               constB = constB+dscvec(k)*dEtotalCm(k)
23678             enddo
23679             constB = constB*dASGL/dscmag3
23680             do k=1,3
23681               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23682               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23683                constA*dEtotalCm(k)-constB*dscvec(k)
23684               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23685               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23686              enddo
23687            else
23688             rcal = 0.0d0
23689             do k=1,3
23690 !              r(k) = c(k,j)-c(k,i+nres)
23691               r(1) = xj
23692               r(2) = yj
23693               r(3) = zj
23694               rcal = rcal+r(k)*r(k)
23695             enddo
23696             ract=sqrt(rcal)
23697             rocal=1.5
23698             epscalc=0.2
23699             r0p=0.5*(rocal+sig0(itype(i,1)))
23700             r06 = r0p**6
23701             r012 = r06*r06
23702             Evan1=epscalc*(r012/rcal**6)
23703             Evan2=epscalc*2*(r06/rcal**3)
23704             r4 = rcal**4
23705             r7 = rcal**7
23706             do k=1,3
23707               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23708               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23709             enddo
23710             do k=1,3
23711               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23712             enddo
23713                  ecation_prot = ecation_prot+ Evan1+Evan2
23714             do  k=1,3
23715                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23716                dEtotalCm(k)
23717               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23718               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23719              enddo
23720          endif ! 13-16 residues
23721        enddo !j
23722        enddo !i
23723        return
23724        end subroutine ecat_prot
23725
23726 !----------------------------------------------------------------------------
23727 !-----------------------------------------------------------------------------
23728 !-----------------------------------------------------------------------------
23729       subroutine eprot_sc_base(escbase)
23730       use calc_data
23731 !      implicit real*8 (a-h,o-z)
23732 !      include 'DIMENSIONS'
23733 !      include 'COMMON.GEO'
23734 !      include 'COMMON.VAR'
23735 !      include 'COMMON.LOCAL'
23736 !      include 'COMMON.CHAIN'
23737 !      include 'COMMON.DERIV'
23738 !      include 'COMMON.NAMES'
23739 !      include 'COMMON.INTERACT'
23740 !      include 'COMMON.IOUNITS'
23741 !      include 'COMMON.CALC'
23742 !      include 'COMMON.CONTROL'
23743 !      include 'COMMON.SBRIDGE'
23744       logical :: lprn
23745 !el local variables
23746       integer :: iint,itypi,itypi1,itypj,subchap
23747       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23748       real(kind=8) :: evdw,sig0ij
23749       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23750                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23751                     sslipi,sslipj,faclip
23752       integer :: ii
23753       real(kind=8) :: fracinbuf
23754        real (kind=8) :: escbase
23755        real (kind=8),dimension(4):: ener
23756        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23757        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23758         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23759         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23760         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23761         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23762         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23763         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23764        real(kind=8),dimension(3,2)::chead,erhead_tail
23765        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23766        integer troll
23767        eps_out=80.0d0
23768        escbase=0.0d0
23769 !       do i=1,nres_molec(1)
23770         do i=ibond_start,ibond_end
23771         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23772         itypi  = itype(i,1)
23773         dxi    = dc_norm(1,nres+i)
23774         dyi    = dc_norm(2,nres+i)
23775         dzi    = dc_norm(3,nres+i)
23776         dsci_inv = vbld_inv(i+nres)
23777         xi=c(1,nres+i)
23778         yi=c(2,nres+i)
23779         zi=c(3,nres+i)
23780         xi=mod(xi,boxxsize)
23781          if (xi.lt.0) xi=xi+boxxsize
23782         yi=mod(yi,boxysize)
23783          if (yi.lt.0) yi=yi+boxysize
23784         zi=mod(zi,boxzsize)
23785          if (zi.lt.0) zi=zi+boxzsize
23786          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23787            itypj= itype(j,2)
23788            if (itype(j,2).eq.ntyp1_molec(2))cycle
23789            xj=c(1,j+nres)
23790            yj=c(2,j+nres)
23791            zj=c(3,j+nres)
23792            xj=dmod(xj,boxxsize)
23793            if (xj.lt.0) xj=xj+boxxsize
23794            yj=dmod(yj,boxysize)
23795            if (yj.lt.0) yj=yj+boxysize
23796            zj=dmod(zj,boxzsize)
23797            if (zj.lt.0) zj=zj+boxzsize
23798           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23799           xj_safe=xj
23800           yj_safe=yj
23801           zj_safe=zj
23802           subchap=0
23803
23804           do xshift=-1,1
23805           do yshift=-1,1
23806           do zshift=-1,1
23807           xj=xj_safe+xshift*boxxsize
23808           yj=yj_safe+yshift*boxysize
23809           zj=zj_safe+zshift*boxzsize
23810           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23811           if(dist_temp.lt.dist_init) then
23812             dist_init=dist_temp
23813             xj_temp=xj
23814             yj_temp=yj
23815             zj_temp=zj
23816             subchap=1
23817           endif
23818           enddo
23819           enddo
23820           enddo
23821           if (subchap.eq.1) then
23822           xj=xj_temp-xi
23823           yj=yj_temp-yi
23824           zj=zj_temp-zi
23825           else
23826           xj=xj_safe-xi
23827           yj=yj_safe-yi
23828           zj=zj_safe-zi
23829           endif
23830           dxj = dc_norm( 1, nres+j )
23831           dyj = dc_norm( 2, nres+j )
23832           dzj = dc_norm( 3, nres+j )
23833 !          print *,i,j,itypi,itypj
23834           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23835           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23836 !          d1i=0.0d0
23837 !          d1j=0.0d0
23838 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23839 ! Gay-berne var's
23840           sig0ij = sigma_scbase( itypi,itypj )
23841           chi1   = chi_scbase( itypi, itypj,1 )
23842           chi2   = chi_scbase( itypi, itypj,2 )
23843 !          chi1=0.0d0
23844 !          chi2=0.0d0
23845           chi12  = chi1 * chi2
23846           chip1  = chipp_scbase( itypi, itypj,1 )
23847           chip2  = chipp_scbase( itypi, itypj,2 )
23848 !          chip1=0.0d0
23849 !          chip2=0.0d0
23850           chip12 = chip1 * chip2
23851 ! not used by momo potential, but needed by sc_angular which is shared
23852 ! by all energy_potential subroutines
23853           alf1   = 0.0d0
23854           alf2   = 0.0d0
23855           alf12  = 0.0d0
23856           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23857 !       a12sq = a12sq * a12sq
23858 ! charge of amino acid itypi is...
23859           chis1 = chis_scbase(itypi,itypj,1)
23860           chis2 = chis_scbase(itypi,itypj,2)
23861           chis12 = chis1 * chis2
23862           sig1 = sigmap1_scbase(itypi,itypj)
23863           sig2 = sigmap2_scbase(itypi,itypj)
23864 !       write (*,*) "sig1 = ", sig1
23865 !       write (*,*) "sig2 = ", sig2
23866 ! alpha factors from Fcav/Gcav
23867           b1 = alphasur_scbase(1,itypi,itypj)
23868 !          b1=0.0d0
23869           b2 = alphasur_scbase(2,itypi,itypj)
23870           b3 = alphasur_scbase(3,itypi,itypj)
23871           b4 = alphasur_scbase(4,itypi,itypj)
23872 ! used to determine whether we want to do quadrupole calculations
23873 ! used by Fgb
23874        eps_in = epsintab_scbase(itypi,itypj)
23875        if (eps_in.eq.0.0) eps_in=1.0
23876        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23877 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23878 !-------------------------------------------------------------------
23879 ! tail location and distance calculations
23880        DO k = 1,3
23881 ! location of polar head is computed by taking hydrophobic centre
23882 ! and moving by a d1 * dc_norm vector
23883 ! see unres publications for very informative images
23884         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23885         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23886 ! distance
23887 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23888 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23889         Rhead_distance(k) = chead(k,2) - chead(k,1)
23890        END DO
23891 ! pitagoras (root of sum of squares)
23892        Rhead = dsqrt( &
23893           (Rhead_distance(1)*Rhead_distance(1)) &
23894         + (Rhead_distance(2)*Rhead_distance(2)) &
23895         + (Rhead_distance(3)*Rhead_distance(3)))
23896 !-------------------------------------------------------------------
23897 ! zero everything that should be zero'ed
23898        evdwij = 0.0d0
23899        ECL = 0.0d0
23900        Elj = 0.0d0
23901        Equad = 0.0d0
23902        Epol = 0.0d0
23903        Fcav=0.0d0
23904        eheadtail = 0.0d0
23905        dGCLdOM1 = 0.0d0
23906        dGCLdOM2 = 0.0d0
23907        dGCLdOM12 = 0.0d0
23908        dPOLdOM1 = 0.0d0
23909        dPOLdOM2 = 0.0d0
23910           Fcav = 0.0d0
23911           dFdR = 0.0d0
23912           dCAVdOM1  = 0.0d0
23913           dCAVdOM2  = 0.0d0
23914           dCAVdOM12 = 0.0d0
23915           dscj_inv = vbld_inv(j+nres)
23916 !          print *,i,j,dscj_inv,dsci_inv
23917 ! rij holds 1/(distance of Calpha atoms)
23918           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23919           rij  = dsqrt(rrij)
23920 !----------------------------
23921           CALL sc_angular
23922 ! this should be in elgrad_init but om's are calculated by sc_angular
23923 ! which in turn is used by older potentials
23924 ! om = omega, sqom = om^2
23925           sqom1  = om1 * om1
23926           sqom2  = om2 * om2
23927           sqom12 = om12 * om12
23928
23929 ! now we calculate EGB - Gey-Berne
23930 ! It will be summed up in evdwij and saved in evdw
23931           sigsq     = 1.0D0  / sigsq
23932           sig       = sig0ij * dsqrt(sigsq)
23933 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23934           rij_shift = 1.0/rij - sig + sig0ij
23935           IF (rij_shift.le.0.0D0) THEN
23936            evdw = 1.0D20
23937            RETURN
23938           END IF
23939           sigder = -sig * sigsq
23940           rij_shift = 1.0D0 / rij_shift
23941           fac       = rij_shift**expon
23942           c1        = fac  * fac * aa_scbase(itypi,itypj)
23943 !          c1        = 0.0d0
23944           c2        = fac  * bb_scbase(itypi,itypj)
23945 !          c2        = 0.0d0
23946           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23947           eps2der   = eps3rt * evdwij
23948           eps3der   = eps2rt * evdwij
23949 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23950           evdwij    = eps2rt * eps3rt * evdwij
23951           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23952           fac    = -expon * (c1 + evdwij) * rij_shift
23953           sigder = fac * sigder
23954 !          fac    = rij * fac
23955 ! Calculate distance derivative
23956           gg(1) =  fac
23957           gg(2) =  fac
23958           gg(3) =  fac
23959 !          if (b2.gt.0.0) then
23960           fac = chis1 * sqom1 + chis2 * sqom2 &
23961           - 2.0d0 * chis12 * om1 * om2 * om12
23962 ! we will use pom later in Gcav, so dont mess with it!
23963           pom = 1.0d0 - chis1 * chis2 * sqom12
23964           Lambf = (1.0d0 - (fac / pom))
23965           Lambf = dsqrt(Lambf)
23966           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23967 !       write (*,*) "sparrow = ", sparrow
23968           Chif = 1.0d0/rij * sparrow
23969           ChiLambf = Chif * Lambf
23970           eagle = dsqrt(ChiLambf)
23971           bat = ChiLambf ** 11.0d0
23972           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23973           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23974           botsq = bot * bot
23975           Fcav = top / bot
23976 !          print *,i,j,Fcav
23977           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23978           dbot = 12.0d0 * b4 * bat * Lambf
23979           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23980 !       dFdR = 0.0d0
23981 !      write (*,*) "dFcav/dR = ", dFdR
23982           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23983           dbot = 12.0d0 * b4 * bat * Chif
23984           eagle = Lambf * pom
23985           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23986           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23987           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23988               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23989
23990           dFdL = ((dtop * bot - top * dbot) / botsq)
23991 !       dFdL = 0.0d0
23992           dCAVdOM1  = dFdL * ( dFdOM1 )
23993           dCAVdOM2  = dFdL * ( dFdOM2 )
23994           dCAVdOM12 = dFdL * ( dFdOM12 )
23995
23996           ertail(1) = xj*rij
23997           ertail(2) = yj*rij
23998           ertail(3) = zj*rij
23999 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24000 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24001 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24002 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24003 !           print *,"EOMY",eom1,eom2,eom12
24004 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24005 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24006 ! here dtail=0.0
24007 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24008 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24009        DO k = 1, 3
24010 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24011 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24012         pom = ertail(k)
24013 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24014         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24015                   - (( dFdR + gg(k) ) * pom)
24016 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24017 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24018 !     &             - ( dFdR * pom )
24019         pom = ertail(k)
24020 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24021         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24022                   + (( dFdR + gg(k) ) * pom)
24023 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24024 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24025 !c!     &             + ( dFdR * pom )
24026
24027         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24028                   - (( dFdR + gg(k) ) * ertail(k))
24029 !c!     &             - ( dFdR * ertail(k))
24030
24031         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24032                   + (( dFdR + gg(k) ) * ertail(k))
24033 !c!     &             + ( dFdR * ertail(k))
24034
24035         gg(k) = 0.0d0
24036 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24037 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24038       END DO
24039
24040 !          else
24041
24042 !          endif
24043 !Now dipole-dipole
24044          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24045        w1 = wdipdip_scbase(1,itypi,itypj)
24046        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24047        w3 = wdipdip_scbase(2,itypi,itypj)
24048 !c!-------------------------------------------------------------------
24049 !c! ECL
24050        fac = (om12 - 3.0d0 * om1 * om2)
24051        c1 = (w1 / (Rhead**3.0d0)) * fac
24052        c2 = (w2 / Rhead ** 6.0d0)  &
24053          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24054        c3= (w3/ Rhead ** 6.0d0)  &
24055          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24056        ECL = c1 - c2 + c3
24057 !c!       write (*,*) "w1 = ", w1
24058 !c!       write (*,*) "w2 = ", w2
24059 !c!       write (*,*) "om1 = ", om1
24060 !c!       write (*,*) "om2 = ", om2
24061 !c!       write (*,*) "om12 = ", om12
24062 !c!       write (*,*) "fac = ", fac
24063 !c!       write (*,*) "c1 = ", c1
24064 !c!       write (*,*) "c2 = ", c2
24065 !c!       write (*,*) "Ecl = ", Ecl
24066 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24067 !c!       write (*,*) "c2_2 = ",
24068 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24069 !c!-------------------------------------------------------------------
24070 !c! dervative of ECL is GCL...
24071 !c! dECL/dr
24072        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24073        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24074          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24075        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24076          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
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        dGCLdOM2 = c1 - c2 + c3
24090 !c! dECL/dom12
24091        c1 = w1 / (Rhead ** 3.0d0)
24092        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24093        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24094        dGCLdOM12 = c1 - c2 + c3
24095        DO k= 1, 3
24096         erhead(k) = Rhead_distance(k)/Rhead
24097        END DO
24098        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24099        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24100        facd1 = d1i * vbld_inv(i+nres)
24101        facd2 = d1j * vbld_inv(j+nres)
24102        DO k = 1, 3
24103
24104         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24105         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24106                   - dGCLdR * pom
24107         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24108         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24109                   + dGCLdR * pom
24110
24111         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24112                   - dGCLdR * erhead(k)
24113         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24114                   + dGCLdR * erhead(k)
24115        END DO
24116        endif
24117 !now charge with dipole eg. ARG-dG
24118        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24119       alphapol1 = alphapol_scbase(itypi,itypj)
24120        w1        = wqdip_scbase(1,itypi,itypj)
24121        w2        = wqdip_scbase(2,itypi,itypj)
24122 !       w1=0.0d0
24123 !       w2=0.0d0
24124 !       pis       = sig0head_scbase(itypi,itypj)
24125 !       eps_head   = epshead_scbase(itypi,itypj)
24126 !c!-------------------------------------------------------------------
24127 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24128        R1 = 0.0d0
24129        DO k = 1, 3
24130 !c! Calculate head-to-tail distances tail is center of side-chain
24131         R1=R1+(c(k,j+nres)-chead(k,1))**2
24132        END DO
24133 !c! Pitagoras
24134        R1 = dsqrt(R1)
24135
24136 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24137 !c!     &        +dhead(1,1,itypi,itypj))**2))
24138 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24139 !c!     &        +dhead(2,1,itypi,itypj))**2))
24140
24141 !c!-------------------------------------------------------------------
24142 !c! ecl
24143        sparrow  = w1  *  om1
24144        hawk     = w2 *  (1.0d0 - sqom2)
24145        Ecl = sparrow / Rhead**2.0d0 &
24146            - hawk    / Rhead**4.0d0
24147 !c!-------------------------------------------------------------------
24148 !c! derivative of ecl is Gcl
24149 !c! dF/dr part
24150        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24151                 + 4.0d0 * hawk    / Rhead**5.0d0
24152 !c! dF/dom1
24153        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24154 !c! dF/dom2
24155        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24156 !c--------------------------------------------------------------------
24157 !c Polarization energy
24158 !c Epol
24159        MomoFac1 = (1.0d0 - chi1 * sqom2)
24160        RR1  = R1 * R1 / MomoFac1
24161        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24162        fgb1 = sqrt( RR1 + a12sq * ee1)
24163 !       eps_inout_fac=0.0d0
24164        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24165 ! derivative of Epol is Gpol...
24166        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24167                 / (fgb1 ** 5.0d0)
24168        dFGBdR1 = ( (R1 / MomoFac1) &
24169              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24170              / ( 2.0d0 * fgb1 )
24171        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24172                * (2.0d0 - 0.5d0 * ee1) ) &
24173                / (2.0d0 * fgb1)
24174        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24175 !       dPOLdR1 = 0.0d0
24176        dPOLdOM1 = 0.0d0
24177        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24178        DO k = 1, 3
24179         erhead(k) = Rhead_distance(k)/Rhead
24180         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24181        END DO
24182
24183        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24184        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24185        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24186 !       bat=0.0d0
24187        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24188        facd1 = d1i * vbld_inv(i+nres)
24189        facd2 = d1j * vbld_inv(j+nres)
24190 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24191
24192        DO k = 1, 3
24193         hawk = (erhead_tail(k,1) + &
24194         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24195 !        facd1=0.0d0
24196 !        facd2=0.0d0
24197         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24198         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24199                    - dGCLdR * pom &
24200                    - dPOLdR1 *  (erhead_tail(k,1))
24201 !     &             - dGLJdR * pom
24202
24203         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24204         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24205                    + dGCLdR * pom  &
24206                    + dPOLdR1 * (erhead_tail(k,1))
24207 !     &             + dGLJdR * pom
24208
24209
24210         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24211                   - dGCLdR * erhead(k) &
24212                   - dPOLdR1 * erhead_tail(k,1)
24213 !     &             - dGLJdR * erhead(k)
24214
24215         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24216                   + dGCLdR * erhead(k)  &
24217                   + dPOLdR1 * erhead_tail(k,1)
24218 !     &             + dGLJdR * erhead(k)
24219
24220        END DO
24221        endif
24222 !       print *,i,j,evdwij,epol,Fcav,ECL
24223        escbase=escbase+evdwij+epol+Fcav+ECL
24224        call sc_grad_scbase
24225          enddo
24226       enddo
24227
24228       return
24229       end subroutine eprot_sc_base
24230       SUBROUTINE sc_grad_scbase
24231       use calc_data
24232
24233        real (kind=8) :: dcosom1(3),dcosom2(3)
24234        eom1  =    &
24235               eps2der * eps2rt_om1   &
24236             - 2.0D0 * alf1 * eps3der &
24237             + sigder * sigsq_om1     &
24238             + dCAVdOM1               &
24239             + dGCLdOM1               &
24240             + dPOLdOM1
24241
24242        eom2  =  &
24243               eps2der * eps2rt_om2   &
24244             + 2.0D0 * alf2 * eps3der &
24245             + sigder * sigsq_om2     &
24246             + dCAVdOM2               &
24247             + dGCLdOM2               &
24248             + dPOLdOM2
24249
24250        eom12 =    &
24251               evdwij  * eps1_om12     &
24252             + eps2der * eps2rt_om12   &
24253             - 2.0D0 * alf12 * eps3der &
24254             + sigder *sigsq_om12      &
24255             + dCAVdOM12               &
24256             + dGCLdOM12
24257
24258 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24259 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24260 !               gg(1),gg(2),"rozne"
24261        DO k = 1, 3
24262         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24263         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24264         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24265         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24266                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24267                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24268         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24269                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24270                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24271         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24272         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24273        END DO
24274        RETURN
24275       END SUBROUTINE sc_grad_scbase
24276
24277
24278       subroutine epep_sc_base(epepbase)
24279       use calc_data
24280       logical :: lprn
24281 !el local variables
24282       integer :: iint,itypi,itypi1,itypj,subchap
24283       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24284       real(kind=8) :: evdw,sig0ij
24285       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24286                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24287                     sslipi,sslipj,faclip
24288       integer :: ii
24289       real(kind=8) :: fracinbuf
24290        real (kind=8) :: epepbase
24291        real (kind=8),dimension(4):: ener
24292        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24293        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24294         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24295         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24296         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24297         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24298         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24299         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24300        real(kind=8),dimension(3,2)::chead,erhead_tail
24301        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24302        integer troll
24303        eps_out=80.0d0
24304        epepbase=0.0d0
24305 !       do i=1,nres_molec(1)-1
24306         do i=ibond_start,ibond_end
24307         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24308 !C        itypi  = itype(i,1)
24309         dxi    = dc_norm(1,i)
24310         dyi    = dc_norm(2,i)
24311         dzi    = dc_norm(3,i)
24312 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24313         dsci_inv = vbld_inv(i+1)/2.0
24314         xi=(c(1,i)+c(1,i+1))/2.0
24315         yi=(c(2,i)+c(2,i+1))/2.0
24316         zi=(c(3,i)+c(3,i+1))/2.0
24317         xi=mod(xi,boxxsize)
24318          if (xi.lt.0) xi=xi+boxxsize
24319         yi=mod(yi,boxysize)
24320          if (yi.lt.0) yi=yi+boxysize
24321         zi=mod(zi,boxzsize)
24322          if (zi.lt.0) zi=zi+boxzsize
24323          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24324            itypj= itype(j,2)
24325            if (itype(j,2).eq.ntyp1_molec(2))cycle
24326            xj=c(1,j+nres)
24327            yj=c(2,j+nres)
24328            zj=c(3,j+nres)
24329            xj=dmod(xj,boxxsize)
24330            if (xj.lt.0) xj=xj+boxxsize
24331            yj=dmod(yj,boxysize)
24332            if (yj.lt.0) yj=yj+boxysize
24333            zj=dmod(zj,boxzsize)
24334            if (zj.lt.0) zj=zj+boxzsize
24335           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24336           xj_safe=xj
24337           yj_safe=yj
24338           zj_safe=zj
24339           subchap=0
24340
24341           do xshift=-1,1
24342           do yshift=-1,1
24343           do zshift=-1,1
24344           xj=xj_safe+xshift*boxxsize
24345           yj=yj_safe+yshift*boxysize
24346           zj=zj_safe+zshift*boxzsize
24347           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24348           if(dist_temp.lt.dist_init) then
24349             dist_init=dist_temp
24350             xj_temp=xj
24351             yj_temp=yj
24352             zj_temp=zj
24353             subchap=1
24354           endif
24355           enddo
24356           enddo
24357           enddo
24358           if (subchap.eq.1) then
24359           xj=xj_temp-xi
24360           yj=yj_temp-yi
24361           zj=zj_temp-zi
24362           else
24363           xj=xj_safe-xi
24364           yj=yj_safe-yi
24365           zj=zj_safe-zi
24366           endif
24367           dxj = dc_norm( 1, nres+j )
24368           dyj = dc_norm( 2, nres+j )
24369           dzj = dc_norm( 3, nres+j )
24370 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24371 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24372
24373 ! Gay-berne var's
24374           sig0ij = sigma_pepbase(itypj )
24375           chi1   = chi_pepbase(itypj,1 )
24376           chi2   = chi_pepbase(itypj,2 )
24377 !          chi1=0.0d0
24378 !          chi2=0.0d0
24379           chi12  = chi1 * chi2
24380           chip1  = chipp_pepbase(itypj,1 )
24381           chip2  = chipp_pepbase(itypj,2 )
24382 !          chip1=0.0d0
24383 !          chip2=0.0d0
24384           chip12 = chip1 * chip2
24385           chis1 = chis_pepbase(itypj,1)
24386           chis2 = chis_pepbase(itypj,2)
24387           chis12 = chis1 * chis2
24388           sig1 = sigmap1_pepbase(itypj)
24389           sig2 = sigmap2_pepbase(itypj)
24390 !       write (*,*) "sig1 = ", sig1
24391 !       write (*,*) "sig2 = ", sig2
24392        DO k = 1,3
24393 ! location of polar head is computed by taking hydrophobic centre
24394 ! and moving by a d1 * dc_norm vector
24395 ! see unres publications for very informative images
24396         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24397 ! + d1i * dc_norm(k, i+nres)
24398         chead(k,2) = c(k, j+nres)
24399 ! + d1j * dc_norm(k, j+nres)
24400 ! distance
24401 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24402 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24403         Rhead_distance(k) = chead(k,2) - chead(k,1)
24404 !        print *,gvdwc_pepbase(k,i)
24405
24406        END DO
24407        Rhead = dsqrt( &
24408           (Rhead_distance(1)*Rhead_distance(1)) &
24409         + (Rhead_distance(2)*Rhead_distance(2)) &
24410         + (Rhead_distance(3)*Rhead_distance(3)))
24411
24412 ! alpha factors from Fcav/Gcav
24413           b1 = alphasur_pepbase(1,itypj)
24414 !          b1=0.0d0
24415           b2 = alphasur_pepbase(2,itypj)
24416           b3 = alphasur_pepbase(3,itypj)
24417           b4 = alphasur_pepbase(4,itypj)
24418           alf1   = 0.0d0
24419           alf2   = 0.0d0
24420           alf12  = 0.0d0
24421           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24422 !          print *,i,j,rrij
24423           rij  = dsqrt(rrij)
24424 !----------------------------
24425        evdwij = 0.0d0
24426        ECL = 0.0d0
24427        Elj = 0.0d0
24428        Equad = 0.0d0
24429        Epol = 0.0d0
24430        Fcav=0.0d0
24431        eheadtail = 0.0d0
24432        dGCLdOM1 = 0.0d0
24433        dGCLdOM2 = 0.0d0
24434        dGCLdOM12 = 0.0d0
24435        dPOLdOM1 = 0.0d0
24436        dPOLdOM2 = 0.0d0
24437           Fcav = 0.0d0
24438           dFdR = 0.0d0
24439           dCAVdOM1  = 0.0d0
24440           dCAVdOM2  = 0.0d0
24441           dCAVdOM12 = 0.0d0
24442           dscj_inv = vbld_inv(j+nres)
24443           CALL sc_angular
24444 ! this should be in elgrad_init but om's are calculated by sc_angular
24445 ! which in turn is used by older potentials
24446 ! om = omega, sqom = om^2
24447           sqom1  = om1 * om1
24448           sqom2  = om2 * om2
24449           sqom12 = om12 * om12
24450
24451 ! now we calculate EGB - Gey-Berne
24452 ! It will be summed up in evdwij and saved in evdw
24453           sigsq     = 1.0D0  / sigsq
24454           sig       = sig0ij * dsqrt(sigsq)
24455           rij_shift = 1.0/rij - sig + sig0ij
24456           IF (rij_shift.le.0.0D0) THEN
24457            evdw = 1.0D20
24458            RETURN
24459           END IF
24460           sigder = -sig * sigsq
24461           rij_shift = 1.0D0 / rij_shift
24462           fac       = rij_shift**expon
24463           c1        = fac  * fac * aa_pepbase(itypj)
24464 !          c1        = 0.0d0
24465           c2        = fac  * bb_pepbase(itypj)
24466 !          c2        = 0.0d0
24467           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24468           eps2der   = eps3rt * evdwij
24469           eps3der   = eps2rt * evdwij
24470 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24471           evdwij    = eps2rt * eps3rt * evdwij
24472           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24473           fac    = -expon * (c1 + evdwij) * rij_shift
24474           sigder = fac * sigder
24475 !          fac    = rij * fac
24476 ! Calculate distance derivative
24477           gg(1) =  fac
24478           gg(2) =  fac
24479           gg(3) =  fac
24480           fac = chis1 * sqom1 + chis2 * sqom2 &
24481           - 2.0d0 * chis12 * om1 * om2 * om12
24482 ! we will use pom later in Gcav, so dont mess with it!
24483           pom = 1.0d0 - chis1 * chis2 * sqom12
24484           Lambf = (1.0d0 - (fac / pom))
24485           Lambf = dsqrt(Lambf)
24486           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24487 !       write (*,*) "sparrow = ", sparrow
24488           Chif = 1.0d0/rij * sparrow
24489           ChiLambf = Chif * Lambf
24490           eagle = dsqrt(ChiLambf)
24491           bat = ChiLambf ** 11.0d0
24492           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24493           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24494           botsq = bot * bot
24495           Fcav = top / bot
24496 !          print *,i,j,Fcav
24497           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24498           dbot = 12.0d0 * b4 * bat * Lambf
24499           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24500 !       dFdR = 0.0d0
24501 !      write (*,*) "dFcav/dR = ", dFdR
24502           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24503           dbot = 12.0d0 * b4 * bat * Chif
24504           eagle = Lambf * pom
24505           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24506           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24507           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24508               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24509
24510           dFdL = ((dtop * bot - top * dbot) / botsq)
24511 !       dFdL = 0.0d0
24512           dCAVdOM1  = dFdL * ( dFdOM1 )
24513           dCAVdOM2  = dFdL * ( dFdOM2 )
24514           dCAVdOM12 = dFdL * ( dFdOM12 )
24515
24516           ertail(1) = xj*rij
24517           ertail(2) = yj*rij
24518           ertail(3) = zj*rij
24519        DO k = 1, 3
24520 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24521 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24522         pom = ertail(k)
24523 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24524         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24525                   - (( dFdR + gg(k) ) * pom)/2.0
24526 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24527 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24528 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24529 !     &             - ( dFdR * pom )
24530         pom = ertail(k)
24531 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24532         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24533                   + (( dFdR + gg(k) ) * pom)
24534 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24535 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24536 !c!     &             + ( dFdR * pom )
24537
24538         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24539                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24540 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24541
24542 !c!     &             - ( dFdR * ertail(k))
24543
24544         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24545                   + (( dFdR + gg(k) ) * ertail(k))
24546 !c!     &             + ( dFdR * ertail(k))
24547
24548         gg(k) = 0.0d0
24549 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24550 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24551       END DO
24552
24553
24554        w1 = wdipdip_pepbase(1,itypj)
24555        w2 = -wdipdip_pepbase(3,itypj)/2.0
24556        w3 = wdipdip_pepbase(2,itypj)
24557 !       w1=0.0d0
24558 !       w2=0.0d0
24559 !c!-------------------------------------------------------------------
24560 !c! ECL
24561 !       w3=0.0d0
24562        fac = (om12 - 3.0d0 * om1 * om2)
24563        c1 = (w1 / (Rhead**3.0d0)) * fac
24564        c2 = (w2 / Rhead ** 6.0d0)  &
24565          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24566        c3= (w3/ Rhead ** 6.0d0)  &
24567          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24568
24569        ECL = c1 - c2 + c3
24570
24571        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24572        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24573          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24574        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24575          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24576
24577        dGCLdR = c1 - c2 + c3
24578 !c! dECL/dom1
24579        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24580        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24581          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24582        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24583        dGCLdOM1 = c1 - c2 + c3
24584 !c! dECL/dom2
24585        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24586        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24587          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24588        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24589
24590        dGCLdOM2 = c1 - c2 + c3
24591 !c! dECL/dom12
24592        c1 = w1 / (Rhead ** 3.0d0)
24593        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24594        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24595        dGCLdOM12 = c1 - c2 + c3
24596        DO k= 1, 3
24597         erhead(k) = Rhead_distance(k)/Rhead
24598        END DO
24599        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24600        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24601 !       facd1 = d1 * vbld_inv(i+nres)
24602 !       facd2 = d2 * vbld_inv(j+nres)
24603        DO k = 1, 3
24604
24605 !        pom = erhead(k)
24606 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24607 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24608 !                  - dGCLdR * pom
24609         pom = erhead(k)
24610 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24611         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24612                   + dGCLdR * pom
24613
24614         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24615                   - dGCLdR * erhead(k)/2.0d0
24616 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24617         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24618                   - dGCLdR * erhead(k)/2.0d0
24619 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24620         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24621                   + dGCLdR * erhead(k)
24622        END DO
24623 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24624        epepbase=epepbase+evdwij+Fcav+ECL
24625        call sc_grad_pepbase
24626        enddo
24627        enddo
24628       END SUBROUTINE epep_sc_base
24629       SUBROUTINE sc_grad_pepbase
24630       use calc_data
24631
24632        real (kind=8) :: dcosom1(3),dcosom2(3)
24633        eom1  =    &
24634               eps2der * eps2rt_om1   &
24635             - 2.0D0 * alf1 * eps3der &
24636             + sigder * sigsq_om1     &
24637             + dCAVdOM1               &
24638             + dGCLdOM1               &
24639             + dPOLdOM1
24640
24641        eom2  =  &
24642               eps2der * eps2rt_om2   &
24643             + 2.0D0 * alf2 * eps3der &
24644             + sigder * sigsq_om2     &
24645             + dCAVdOM2               &
24646             + dGCLdOM2               &
24647             + dPOLdOM2
24648
24649        eom12 =    &
24650               evdwij  * eps1_om12     &
24651             + eps2der * eps2rt_om12   &
24652             - 2.0D0 * alf12 * eps3der &
24653             + sigder *sigsq_om12      &
24654             + dCAVdOM12               &
24655             + dGCLdOM12
24656 !        om12=0.0
24657 !        eom12=0.0
24658 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24659 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24660 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24661 !                 *dsci_inv*2.0
24662 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24663 !               gg(1),gg(2),"rozne"
24664        DO k = 1, 3
24665         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24666         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24667         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24668         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24669                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24670                  *dsci_inv*2.0 &
24671                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24672         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24673                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24674                  *dsci_inv*2.0 &
24675                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24676 !         print *,eom12,eom2,om12,om2
24677 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24678 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24679         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24680                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24681                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24682         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24683        END DO
24684        RETURN
24685       END SUBROUTINE sc_grad_pepbase
24686       subroutine eprot_sc_phosphate(escpho)
24687       use calc_data
24688 !      implicit real*8 (a-h,o-z)
24689 !      include 'DIMENSIONS'
24690 !      include 'COMMON.GEO'
24691 !      include 'COMMON.VAR'
24692 !      include 'COMMON.LOCAL'
24693 !      include 'COMMON.CHAIN'
24694 !      include 'COMMON.DERIV'
24695 !      include 'COMMON.NAMES'
24696 !      include 'COMMON.INTERACT'
24697 !      include 'COMMON.IOUNITS'
24698 !      include 'COMMON.CALC'
24699 !      include 'COMMON.CONTROL'
24700 !      include 'COMMON.SBRIDGE'
24701       logical :: lprn
24702 !el local variables
24703       integer :: iint,itypi,itypi1,itypj,subchap
24704       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24705       real(kind=8) :: evdw,sig0ij
24706       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24707                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24708                     sslipi,sslipj,faclip,alpha_sco
24709       integer :: ii
24710       real(kind=8) :: fracinbuf
24711        real (kind=8) :: escpho
24712        real (kind=8),dimension(4):: ener
24713        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24714        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24715         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24716         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24717         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24718         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24719         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24720         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24721        real(kind=8),dimension(3,2)::chead,erhead_tail
24722        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24723        integer troll
24724        eps_out=80.0d0
24725        escpho=0.0d0
24726 !       do i=1,nres_molec(1)
24727         do i=ibond_start,ibond_end
24728         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24729         itypi  = itype(i,1)
24730         dxi    = dc_norm(1,nres+i)
24731         dyi    = dc_norm(2,nres+i)
24732         dzi    = dc_norm(3,nres+i)
24733         dsci_inv = vbld_inv(i+nres)
24734         xi=c(1,nres+i)
24735         yi=c(2,nres+i)
24736         zi=c(3,nres+i)
24737         xi=mod(xi,boxxsize)
24738          if (xi.lt.0) xi=xi+boxxsize
24739         yi=mod(yi,boxysize)
24740          if (yi.lt.0) yi=yi+boxysize
24741         zi=mod(zi,boxzsize)
24742          if (zi.lt.0) zi=zi+boxzsize
24743          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24744            itypj= itype(j,2)
24745            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24746             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24747            xj=(c(1,j)+c(1,j+1))/2.0
24748            yj=(c(2,j)+c(2,j+1))/2.0
24749            zj=(c(3,j)+c(3,j+1))/2.0
24750            xj=dmod(xj,boxxsize)
24751            if (xj.lt.0) xj=xj+boxxsize
24752            yj=dmod(yj,boxysize)
24753            if (yj.lt.0) yj=yj+boxysize
24754            zj=dmod(zj,boxzsize)
24755            if (zj.lt.0) zj=zj+boxzsize
24756           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24757           xj_safe=xj
24758           yj_safe=yj
24759           zj_safe=zj
24760           subchap=0
24761           do xshift=-1,1
24762           do yshift=-1,1
24763           do zshift=-1,1
24764           xj=xj_safe+xshift*boxxsize
24765           yj=yj_safe+yshift*boxysize
24766           zj=zj_safe+zshift*boxzsize
24767           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24768           if(dist_temp.lt.dist_init) then
24769             dist_init=dist_temp
24770             xj_temp=xj
24771             yj_temp=yj
24772             zj_temp=zj
24773             subchap=1
24774           endif
24775           enddo
24776           enddo
24777           enddo
24778           if (subchap.eq.1) then
24779           xj=xj_temp-xi
24780           yj=yj_temp-yi
24781           zj=zj_temp-zi
24782           else
24783           xj=xj_safe-xi
24784           yj=yj_safe-yi
24785           zj=zj_safe-zi
24786           endif
24787           dxj = dc_norm( 1,j )
24788           dyj = dc_norm( 2,j )
24789           dzj = dc_norm( 3,j )
24790           dscj_inv = vbld_inv(j+1)
24791
24792 ! Gay-berne var's
24793           sig0ij = sigma_scpho(itypi )
24794           chi1   = chi_scpho(itypi,1 )
24795           chi2   = chi_scpho(itypi,2 )
24796 !          chi1=0.0d0
24797 !          chi2=0.0d0
24798           chi12  = chi1 * chi2
24799           chip1  = chipp_scpho(itypi,1 )
24800           chip2  = chipp_scpho(itypi,2 )
24801 !          chip1=0.0d0
24802 !          chip2=0.0d0
24803           chip12 = chip1 * chip2
24804           chis1 = chis_scpho(itypi,1)
24805           chis2 = chis_scpho(itypi,2)
24806           chis12 = chis1 * chis2
24807           sig1 = sigmap1_scpho(itypi)
24808           sig2 = sigmap2_scpho(itypi)
24809 !       write (*,*) "sig1 = ", sig1
24810 !       write (*,*) "sig1 = ", sig1
24811 !       write (*,*) "sig2 = ", sig2
24812 ! alpha factors from Fcav/Gcav
24813           alf1   = 0.0d0
24814           alf2   = 0.0d0
24815           alf12  = 0.0d0
24816           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24817
24818           b1 = alphasur_scpho(1,itypi)
24819 !          b1=0.0d0
24820           b2 = alphasur_scpho(2,itypi)
24821           b3 = alphasur_scpho(3,itypi)
24822           b4 = alphasur_scpho(4,itypi)
24823 ! used to determine whether we want to do quadrupole calculations
24824 ! used by Fgb
24825        eps_in = epsintab_scpho(itypi)
24826        if (eps_in.eq.0.0) eps_in=1.0
24827        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24828 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24829 !-------------------------------------------------------------------
24830 ! tail location and distance calculations
24831           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24832           d1j = 0.0
24833        DO k = 1,3
24834 ! location of polar head is computed by taking hydrophobic centre
24835 ! and moving by a d1 * dc_norm vector
24836 ! see unres publications for very informative images
24837         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24838         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24839 ! distance
24840 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24841 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24842         Rhead_distance(k) = chead(k,2) - chead(k,1)
24843        END DO
24844 ! pitagoras (root of sum of squares)
24845        Rhead = dsqrt( &
24846           (Rhead_distance(1)*Rhead_distance(1)) &
24847         + (Rhead_distance(2)*Rhead_distance(2)) &
24848         + (Rhead_distance(3)*Rhead_distance(3)))
24849        Rhead_sq=Rhead**2.0
24850 !-------------------------------------------------------------------
24851 ! zero everything that should be zero'ed
24852        evdwij = 0.0d0
24853        ECL = 0.0d0
24854        Elj = 0.0d0
24855        Equad = 0.0d0
24856        Epol = 0.0d0
24857        Fcav=0.0d0
24858        eheadtail = 0.0d0
24859        dGCLdR=0.0d0
24860        dGCLdOM1 = 0.0d0
24861        dGCLdOM2 = 0.0d0
24862        dGCLdOM12 = 0.0d0
24863        dPOLdOM1 = 0.0d0
24864        dPOLdOM2 = 0.0d0
24865           Fcav = 0.0d0
24866           dFdR = 0.0d0
24867           dCAVdOM1  = 0.0d0
24868           dCAVdOM2  = 0.0d0
24869           dCAVdOM12 = 0.0d0
24870           dscj_inv = vbld_inv(j+1)/2.0
24871 !dhead_scbasej(itypi,itypj)
24872 !          print *,i,j,dscj_inv,dsci_inv
24873 ! rij holds 1/(distance of Calpha atoms)
24874           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24875           rij  = dsqrt(rrij)
24876 !----------------------------
24877           CALL sc_angular
24878 ! this should be in elgrad_init but om's are calculated by sc_angular
24879 ! which in turn is used by older potentials
24880 ! om = omega, sqom = om^2
24881           sqom1  = om1 * om1
24882           sqom2  = om2 * om2
24883           sqom12 = om12 * om12
24884
24885 ! now we calculate EGB - Gey-Berne
24886 ! It will be summed up in evdwij and saved in evdw
24887           sigsq     = 1.0D0  / sigsq
24888           sig       = sig0ij * dsqrt(sigsq)
24889 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24890           rij_shift = 1.0/rij - sig + sig0ij
24891           IF (rij_shift.le.0.0D0) THEN
24892            evdw = 1.0D20
24893            RETURN
24894           END IF
24895           sigder = -sig * sigsq
24896           rij_shift = 1.0D0 / rij_shift
24897           fac       = rij_shift**expon
24898           c1        = fac  * fac * aa_scpho(itypi)
24899 !          c1        = 0.0d0
24900           c2        = fac  * bb_scpho(itypi)
24901 !          c2        = 0.0d0
24902           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24903           eps2der   = eps3rt * evdwij
24904           eps3der   = eps2rt * evdwij
24905 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24906           evdwij    = eps2rt * eps3rt * evdwij
24907           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24908           fac    = -expon * (c1 + evdwij) * rij_shift
24909           sigder = fac * sigder
24910 !          fac    = rij * fac
24911 ! Calculate distance derivative
24912           gg(1) =  fac
24913           gg(2) =  fac
24914           gg(3) =  fac
24915           fac = chis1 * sqom1 + chis2 * sqom2 &
24916           - 2.0d0 * chis12 * om1 * om2 * om12
24917 ! we will use pom later in Gcav, so dont mess with it!
24918           pom = 1.0d0 - chis1 * chis2 * sqom12
24919           Lambf = (1.0d0 - (fac / pom))
24920           Lambf = dsqrt(Lambf)
24921           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24922 !       write (*,*) "sparrow = ", sparrow
24923           Chif = 1.0d0/rij * sparrow
24924           ChiLambf = Chif * Lambf
24925           eagle = dsqrt(ChiLambf)
24926           bat = ChiLambf ** 11.0d0
24927           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24928           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24929           botsq = bot * bot
24930           Fcav = top / bot
24931           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24932           dbot = 12.0d0 * b4 * bat * Lambf
24933           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24934 !       dFdR = 0.0d0
24935 !      write (*,*) "dFcav/dR = ", dFdR
24936           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24937           dbot = 12.0d0 * b4 * bat * Chif
24938           eagle = Lambf * pom
24939           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24940           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24941           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24942               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24943
24944           dFdL = ((dtop * bot - top * dbot) / botsq)
24945 !       dFdL = 0.0d0
24946           dCAVdOM1  = dFdL * ( dFdOM1 )
24947           dCAVdOM2  = dFdL * ( dFdOM2 )
24948           dCAVdOM12 = dFdL * ( dFdOM12 )
24949
24950           ertail(1) = xj*rij
24951           ertail(2) = yj*rij
24952           ertail(3) = zj*rij
24953        DO k = 1, 3
24954 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24955 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24956 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24957
24958         pom = ertail(k)
24959 !        print *,pom,gg(k),dFdR
24960 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24961         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24962                   - (( dFdR + gg(k) ) * pom)
24963 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24964 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24965 !     &             - ( dFdR * pom )
24966 !        pom = ertail(k)
24967 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24968 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24969 !                  + (( dFdR + gg(k) ) * pom)
24970 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24971 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24972 !c!     &             + ( dFdR * pom )
24973
24974         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24975                   - (( dFdR + gg(k) ) * ertail(k))
24976 !c!     &             - ( dFdR * ertail(k))
24977
24978         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24979                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24980
24981         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24982                   + (( dFdR + gg(k) ) * ertail(k))/2.0
24983
24984 !c!     &             + ( dFdR * ertail(k))
24985
24986         gg(k) = 0.0d0
24987         ENDDO
24988 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24989 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24990 !      alphapol1 = alphapol_scpho(itypi)
24991        if (wqq_scpho(itypi).ne.0.0) then
24992        Qij=wqq_scpho(itypi)/eps_in
24993        alpha_sco=1.d0/alphi_scpho(itypi)
24994 !       Qij=0.0
24995        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24996 !c! derivative of Ecl is Gcl...
24997        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24998                 (Rhead*alpha_sco+1) ) / Rhead_sq
24999        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25000        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25001        w1        = wqdip_scpho(1,itypi)
25002        w2        = wqdip_scpho(2,itypi)
25003 !       w1=0.0d0
25004 !       w2=0.0d0
25005 !       pis       = sig0head_scbase(itypi,itypj)
25006 !       eps_head   = epshead_scbase(itypi,itypj)
25007 !c!-------------------------------------------------------------------
25008
25009 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25010 !c!     &        +dhead(1,1,itypi,itypj))**2))
25011 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25012 !c!     &        +dhead(2,1,itypi,itypj))**2))
25013
25014 !c!-------------------------------------------------------------------
25015 !c! ecl
25016        sparrow  = w1  *  om1
25017        hawk     = w2 *  (1.0d0 - sqom2)
25018        Ecl = sparrow / Rhead**2.0d0 &
25019            - hawk    / Rhead**4.0d0
25020 !c!-------------------------------------------------------------------
25021        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25022            1.0/rij,sparrow
25023
25024 !c! derivative of ecl is Gcl
25025 !c! dF/dr part
25026        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25027                 + 4.0d0 * hawk    / Rhead**5.0d0
25028 !c! dF/dom1
25029        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25030 !c! dF/dom2
25031        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25032        endif
25033
25034 !c--------------------------------------------------------------------
25035 !c Polarization energy
25036 !c Epol
25037        R1 = 0.0d0
25038        DO k = 1, 3
25039 !c! Calculate head-to-tail distances tail is center of side-chain
25040         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25041        END DO
25042 !c! Pitagoras
25043        R1 = dsqrt(R1)
25044
25045       alphapol1 = alphapol_scpho(itypi)
25046 !      alphapol1=0.0
25047        MomoFac1 = (1.0d0 - chi2 * sqom1)
25048        RR1  = R1 * R1 / MomoFac1
25049        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25050 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25051        fgb1 = sqrt( RR1 + a12sq * ee1)
25052 !       eps_inout_fac=0.0d0
25053        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25054 ! derivative of Epol is Gpol...
25055        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25056                 / (fgb1 ** 5.0d0)
25057        dFGBdR1 = ( (R1 / MomoFac1) &
25058              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25059              / ( 2.0d0 * fgb1 )
25060        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25061                * (2.0d0 - 0.5d0 * ee1) ) &
25062                / (2.0d0 * fgb1)
25063        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25064 !       dPOLdR1 = 0.0d0
25065 !       dPOLdOM1 = 0.0d0
25066        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25067                * (2.0d0 - 0.5d0 * ee1) ) &
25068                / (2.0d0 * fgb1)
25069
25070        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25071        dPOLdOM2 = 0.0
25072        DO k = 1, 3
25073         erhead(k) = Rhead_distance(k)/Rhead
25074         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25075        END DO
25076
25077        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25078        erdxj = scalar( erhead(1), dC_norm(1,j) )
25079        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25080 !       bat=0.0d0
25081        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25082        facd1 = d1i * vbld_inv(i+nres)
25083        facd2 = d1j * vbld_inv(j)
25084 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25085
25086        DO k = 1, 3
25087         hawk = (erhead_tail(k,1) + &
25088         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25089 !        facd1=0.0d0
25090 !        facd2=0.0d0
25091 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25092 !                pom,(erhead_tail(k,1))
25093
25094 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25095         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25096         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25097                    - dGCLdR * pom &
25098                    - dPOLdR1 *  (erhead_tail(k,1))
25099 !     &             - dGLJdR * pom
25100
25101         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25102 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25103 !                   + dGCLdR * pom  &
25104 !                   + dPOLdR1 * (erhead_tail(k,1))
25105 !     &             + dGLJdR * pom
25106
25107
25108         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25109                   - dGCLdR * erhead(k) &
25110                   - dPOLdR1 * erhead_tail(k,1)
25111 !     &             - dGLJdR * erhead(k)
25112
25113         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25114                   + (dGCLdR * erhead(k)  &
25115                   + dPOLdR1 * erhead_tail(k,1))/2.0
25116         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25117                   + (dGCLdR * erhead(k)  &
25118                   + dPOLdR1 * erhead_tail(k,1))/2.0
25119
25120 !     &             + dGLJdR * erhead(k)
25121 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25122
25123        END DO
25124 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25125        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25126         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25127        escpho=escpho+evdwij+epol+Fcav+ECL
25128        call sc_grad_scpho
25129          enddo
25130
25131       enddo
25132
25133       return
25134       end subroutine eprot_sc_phosphate
25135       SUBROUTINE sc_grad_scpho
25136       use calc_data
25137
25138        real (kind=8) :: dcosom1(3),dcosom2(3)
25139        eom1  =    &
25140               eps2der * eps2rt_om1   &
25141             - 2.0D0 * alf1 * eps3der &
25142             + sigder * sigsq_om1     &
25143             + dCAVdOM1               &
25144             + dGCLdOM1               &
25145             + dPOLdOM1
25146
25147        eom2  =  &
25148               eps2der * eps2rt_om2   &
25149             + 2.0D0 * alf2 * eps3der &
25150             + sigder * sigsq_om2     &
25151             + dCAVdOM2               &
25152             + dGCLdOM2               &
25153             + dPOLdOM2
25154
25155        eom12 =    &
25156               evdwij  * eps1_om12     &
25157             + eps2der * eps2rt_om12   &
25158             - 2.0D0 * alf12 * eps3der &
25159             + sigder *sigsq_om12      &
25160             + dCAVdOM12               &
25161             + dGCLdOM12
25162 !        om12=0.0
25163 !        eom12=0.0
25164 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25165 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25166 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25167 !                 *dsci_inv*2.0
25168 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25169 !               gg(1),gg(2),"rozne"
25170        DO k = 1, 3
25171         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25172         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25173         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25174         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25175                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25176                  *dscj_inv*2.0 &
25177                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25178         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25179                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25180                  *dscj_inv*2.0 &
25181                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25182         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25183                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25184                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25185
25186 !         print *,eom12,eom2,om12,om2
25187 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25188 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25189 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25190 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25191 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25192         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25193        END DO
25194        RETURN
25195       END SUBROUTINE sc_grad_scpho
25196       subroutine eprot_pep_phosphate(epeppho)
25197       use calc_data
25198 !      implicit real*8 (a-h,o-z)
25199 !      include 'DIMENSIONS'
25200 !      include 'COMMON.GEO'
25201 !      include 'COMMON.VAR'
25202 !      include 'COMMON.LOCAL'
25203 !      include 'COMMON.CHAIN'
25204 !      include 'COMMON.DERIV'
25205 !      include 'COMMON.NAMES'
25206 !      include 'COMMON.INTERACT'
25207 !      include 'COMMON.IOUNITS'
25208 !      include 'COMMON.CALC'
25209 !      include 'COMMON.CONTROL'
25210 !      include 'COMMON.SBRIDGE'
25211       logical :: lprn
25212 !el local variables
25213       integer :: iint,itypi,itypi1,itypj,subchap
25214       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25215       real(kind=8) :: evdw,sig0ij
25216       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25217                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25218                     sslipi,sslipj,faclip
25219       integer :: ii
25220       real(kind=8) :: fracinbuf
25221        real (kind=8) :: epeppho
25222        real (kind=8),dimension(4):: ener
25223        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25224        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25225         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25226         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25227         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25228         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25229         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25230         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25231        real(kind=8),dimension(3,2)::chead,erhead_tail
25232        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25233        integer troll
25234        real (kind=8) :: dcosom1(3),dcosom2(3)
25235        epeppho=0.0d0
25236 !       do i=1,nres_molec(1)
25237         do i=ibond_start,ibond_end
25238         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25239         itypi  = itype(i,1)
25240         dsci_inv = vbld_inv(i+1)/2.0
25241         dxi    = dc_norm(1,i)
25242         dyi    = dc_norm(2,i)
25243         dzi    = dc_norm(3,i)
25244         xi=(c(1,i)+c(1,i+1))/2.0
25245         yi=(c(2,i)+c(2,i+1))/2.0
25246         zi=(c(3,i)+c(3,i+1))/2.0
25247         xi=mod(xi,boxxsize)
25248          if (xi.lt.0) xi=xi+boxxsize
25249         yi=mod(yi,boxysize)
25250          if (yi.lt.0) yi=yi+boxysize
25251         zi=mod(zi,boxzsize)
25252          if (zi.lt.0) zi=zi+boxzsize
25253          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25254            itypj= itype(j,2)
25255            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25256             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25257            xj=(c(1,j)+c(1,j+1))/2.0
25258            yj=(c(2,j)+c(2,j+1))/2.0
25259            zj=(c(3,j)+c(3,j+1))/2.0
25260            xj=dmod(xj,boxxsize)
25261            if (xj.lt.0) xj=xj+boxxsize
25262            yj=dmod(yj,boxysize)
25263            if (yj.lt.0) yj=yj+boxysize
25264            zj=dmod(zj,boxzsize)
25265            if (zj.lt.0) zj=zj+boxzsize
25266           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25267           xj_safe=xj
25268           yj_safe=yj
25269           zj_safe=zj
25270           subchap=0
25271           do xshift=-1,1
25272           do yshift=-1,1
25273           do zshift=-1,1
25274           xj=xj_safe+xshift*boxxsize
25275           yj=yj_safe+yshift*boxysize
25276           zj=zj_safe+zshift*boxzsize
25277           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25278           if(dist_temp.lt.dist_init) then
25279             dist_init=dist_temp
25280             xj_temp=xj
25281             yj_temp=yj
25282             zj_temp=zj
25283             subchap=1
25284           endif
25285           enddo
25286           enddo
25287           enddo
25288           if (subchap.eq.1) then
25289           xj=xj_temp-xi
25290           yj=yj_temp-yi
25291           zj=zj_temp-zi
25292           else
25293           xj=xj_safe-xi
25294           yj=yj_safe-yi
25295           zj=zj_safe-zi
25296           endif
25297           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25298           rij  = dsqrt(rrij)
25299           dxj = dc_norm( 1,j )
25300           dyj = dc_norm( 2,j )
25301           dzj = dc_norm( 3,j )
25302           dscj_inv = vbld_inv(j+1)/2.0
25303 ! Gay-berne var's
25304           sig0ij = sigma_peppho
25305 !          chi1=0.0d0
25306 !          chi2=0.0d0
25307           chi12  = chi1 * chi2
25308 !          chip1=0.0d0
25309 !          chip2=0.0d0
25310           chip12 = chip1 * chip2
25311 !          chis1 = 0.0d0
25312 !          chis2 = 0.0d0
25313           chis12 = chis1 * chis2
25314           sig1 = sigmap1_peppho
25315           sig2 = sigmap2_peppho
25316 !       write (*,*) "sig1 = ", sig1
25317 !       write (*,*) "sig1 = ", sig1
25318 !       write (*,*) "sig2 = ", sig2
25319 ! alpha factors from Fcav/Gcav
25320           alf1   = 0.0d0
25321           alf2   = 0.0d0
25322           alf12  = 0.0d0
25323           b1 = alphasur_peppho(1)
25324 !          b1=0.0d0
25325           b2 = alphasur_peppho(2)
25326           b3 = alphasur_peppho(3)
25327           b4 = alphasur_peppho(4)
25328           CALL sc_angular
25329        sqom1=om1*om1
25330        evdwij = 0.0d0
25331        ECL = 0.0d0
25332        Elj = 0.0d0
25333        Equad = 0.0d0
25334        Epol = 0.0d0
25335        Fcav=0.0d0
25336        eheadtail = 0.0d0
25337        dGCLdR=0.0d0
25338        dGCLdOM1 = 0.0d0
25339        dGCLdOM2 = 0.0d0
25340        dGCLdOM12 = 0.0d0
25341        dPOLdOM1 = 0.0d0
25342        dPOLdOM2 = 0.0d0
25343           Fcav = 0.0d0
25344           dFdR = 0.0d0
25345           dCAVdOM1  = 0.0d0
25346           dCAVdOM2  = 0.0d0
25347           dCAVdOM12 = 0.0d0
25348           rij_shift = rij
25349           fac       = rij_shift**expon
25350           c1        = fac  * fac * aa_peppho
25351 !          c1        = 0.0d0
25352           c2        = fac  * bb_peppho
25353 !          c2        = 0.0d0
25354           evdwij    =  c1 + c2
25355 ! Now cavity....................
25356        eagle = dsqrt(1.0/rij_shift)
25357        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25358           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25359           botsq = bot * bot
25360           Fcav = top / bot
25361           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25362           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25363           dFdR = ((dtop * bot - top * dbot) / botsq)
25364        w1        = wqdip_peppho(1)
25365        w2        = wqdip_peppho(2)
25366 !       w1=0.0d0
25367 !       w2=0.0d0
25368 !       pis       = sig0head_scbase(itypi,itypj)
25369 !       eps_head   = epshead_scbase(itypi,itypj)
25370 !c!-------------------------------------------------------------------
25371
25372 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25373 !c!     &        +dhead(1,1,itypi,itypj))**2))
25374 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25375 !c!     &        +dhead(2,1,itypi,itypj))**2))
25376
25377 !c!-------------------------------------------------------------------
25378 !c! ecl
25379        sparrow  = w1  *  om1
25380        hawk     = w2 *  (1.0d0 - sqom1)
25381        Ecl = sparrow * rij_shift**2.0d0 &
25382            - hawk    * rij_shift**4.0d0
25383 !c!-------------------------------------------------------------------
25384 !c! derivative of ecl is Gcl
25385 !c! dF/dr part
25386 !       rij_shift=5.0
25387        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25388                 + 4.0d0 * hawk    * rij_shift**5.0d0
25389 !c! dF/dom1
25390        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25391 !c! dF/dom2
25392        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25393        eom1  =    dGCLdOM1+dGCLdOM2
25394        eom2  =    0.0
25395
25396           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25397 !          fac=0.0
25398           gg(1) =  fac*xj*rij
25399           gg(2) =  fac*yj*rij
25400           gg(3) =  fac*zj*rij
25401          do k=1,3
25402          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25403          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25404          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25405          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25406          gg(k)=0.0
25407          enddo
25408
25409       DO k = 1, 3
25410         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25411         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25412         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25413         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25414 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25415         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25416 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25417         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25418                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25419         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25420                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25421         enddo
25422        epeppho=epeppho+evdwij+Fcav+ECL
25423 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25424        enddo
25425        enddo
25426       end subroutine eprot_pep_phosphate
25427 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25428       subroutine emomo(evdw)
25429       use calc_data
25430       use comm_momo
25431 !      implicit real*8 (a-h,o-z)
25432 !      include 'DIMENSIONS'
25433 !      include 'COMMON.GEO'
25434 !      include 'COMMON.VAR'
25435 !      include 'COMMON.LOCAL'
25436 !      include 'COMMON.CHAIN'
25437 !      include 'COMMON.DERIV'
25438 !      include 'COMMON.NAMES'
25439 !      include 'COMMON.INTERACT'
25440 !      include 'COMMON.IOUNITS'
25441 !      include 'COMMON.CALC'
25442 !      include 'COMMON.CONTROL'
25443 !      include 'COMMON.SBRIDGE'
25444       logical :: lprn
25445 !el local variables
25446       integer :: iint,itypi1,subchap,isel
25447       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25448       real(kind=8) :: evdw
25449       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25450                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25451                     sslipi,sslipj,faclip,alpha_sco
25452       integer :: ii
25453       real(kind=8) :: fracinbuf
25454        real (kind=8) :: escpho
25455        real (kind=8),dimension(4):: ener
25456        real(kind=8) :: b1,b2,egb
25457        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25458         Lambf,&
25459         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25460         dFdOM2,dFdL,dFdOM12,&
25461         federmaus,&
25462         d1i,d1j
25463 !       real(kind=8),dimension(3,2)::erhead_tail
25464 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25465        real(kind=8) ::  facd4, adler, Fgb, facd3
25466        integer troll,jj,istate
25467        real (kind=8) :: dcosom1(3),dcosom2(3)
25468        evdw=0.0d0
25469        eps_out=80.0d0
25470        sss_ele_cut=1.0d0
25471 !       print *,"EVDW KURW",evdw,nres
25472       do i=iatsc_s,iatsc_e
25473 !        print *,"I am in EVDW",i
25474         itypi=iabs(itype(i,1))
25475 !        if (i.ne.47) cycle
25476         if (itypi.eq.ntyp1) cycle
25477         itypi1=iabs(itype(i+1,1))
25478         xi=c(1,nres+i)
25479         yi=c(2,nres+i)
25480         zi=c(3,nres+i)
25481           xi=dmod(xi,boxxsize)
25482           if (xi.lt.0) xi=xi+boxxsize
25483           yi=dmod(yi,boxysize)
25484           if (yi.lt.0) yi=yi+boxysize
25485           zi=dmod(zi,boxzsize)
25486           if (zi.lt.0) zi=zi+boxzsize
25487
25488        if ((zi.gt.bordlipbot)  &
25489         .and.(zi.lt.bordliptop)) then
25490 !C the energy transfer exist
25491         if (zi.lt.buflipbot) then
25492 !C what fraction I am in
25493          fracinbuf=1.0d0-  &
25494               ((zi-bordlipbot)/lipbufthick)
25495 !C lipbufthick is thickenes of lipid buffore
25496          sslipi=sscalelip(fracinbuf)
25497          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25498         elseif (zi.gt.bufliptop) then
25499          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25500          sslipi=sscalelip(fracinbuf)
25501          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25502         else
25503          sslipi=1.0d0
25504          ssgradlipi=0.0
25505         endif
25506        else
25507          sslipi=0.0d0
25508          ssgradlipi=0.0
25509        endif
25510 !       print *, sslipi,ssgradlipi
25511         dxi=dc_norm(1,nres+i)
25512         dyi=dc_norm(2,nres+i)
25513         dzi=dc_norm(3,nres+i)
25514 !        dsci_inv=dsc_inv(itypi)
25515         dsci_inv=vbld_inv(i+nres)
25516 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25517 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25518 !
25519 ! Calculate SC interaction energy.
25520 !
25521         do iint=1,nint_gr(i)
25522           do j=istart(i,iint),iend(i,iint)
25523 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25524             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25525               call dyn_ssbond_ene(i,j,evdwij)
25526               evdw=evdw+evdwij
25527               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25528                               'evdw',i,j,evdwij,' ss'
25529 !              if (energy_dec) write (iout,*) &
25530 !                              'evdw',i,j,evdwij,' ss'
25531              do k=j+1,iend(i,iint)
25532 !C search over all next residues
25533               if (dyn_ss_mask(k)) then
25534 !C check if they are cysteins
25535 !C              write(iout,*) 'k=',k
25536
25537 !c              write(iout,*) "PRZED TRI", evdwij
25538 !               evdwij_przed_tri=evdwij
25539               call triple_ssbond_ene(i,j,k,evdwij)
25540 !c               if(evdwij_przed_tri.ne.evdwij) then
25541 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25542 !c               endif
25543
25544 !c              write(iout,*) "PO TRI", evdwij
25545 !C call the energy function that removes the artifical triple disulfide
25546 !C bond the soubroutine is located in ssMD.F
25547               evdw=evdw+evdwij
25548               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25549                             'evdw',i,j,evdwij,'tss'
25550               endif!dyn_ss_mask(k)
25551              enddo! k
25552             ELSE
25553 !el            ind=ind+1
25554             itypj=iabs(itype(j,1))
25555             if (itypj.eq.ntyp1) cycle
25556              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25557
25558 !             if (j.ne.78) cycle
25559 !            dscj_inv=dsc_inv(itypj)
25560             dscj_inv=vbld_inv(j+nres)
25561            xj=c(1,j+nres)
25562            yj=c(2,j+nres)
25563            zj=c(3,j+nres)
25564            xj=dmod(xj,boxxsize)
25565            if (xj.lt.0) xj=xj+boxxsize
25566            yj=dmod(yj,boxysize)
25567            if (yj.lt.0) yj=yj+boxysize
25568            zj=dmod(zj,boxzsize)
25569            if (zj.lt.0) zj=zj+boxzsize
25570           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25571           xj_safe=xj
25572           yj_safe=yj
25573           zj_safe=zj
25574           subchap=0
25575
25576           do xshift=-1,1
25577           do yshift=-1,1
25578           do zshift=-1,1
25579           xj=xj_safe+xshift*boxxsize
25580           yj=yj_safe+yshift*boxysize
25581           zj=zj_safe+zshift*boxzsize
25582           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25583           if(dist_temp.lt.dist_init) then
25584             dist_init=dist_temp
25585             xj_temp=xj
25586             yj_temp=yj
25587             zj_temp=zj
25588             subchap=1
25589           endif
25590           enddo
25591           enddo
25592           enddo
25593           if (subchap.eq.1) then
25594           xj=xj_temp-xi
25595           yj=yj_temp-yi
25596           zj=zj_temp-zi
25597           else
25598           xj=xj_safe-xi
25599           yj=yj_safe-yi
25600           zj=zj_safe-zi
25601           endif
25602           dxj = dc_norm( 1, nres+j )
25603           dyj = dc_norm( 2, nres+j )
25604           dzj = dc_norm( 3, nres+j )
25605 !          print *,i,j,itypi,itypj
25606 !          d1i=0.0d0
25607 !          d1j=0.0d0
25608 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25609 ! Gay-berne var's
25610 !1!          sig0ij = sigma_scsc( itypi,itypj )
25611 !          chi1=0.0d0
25612 !          chi2=0.0d0
25613 !          chip1=0.0d0
25614 !          chip2=0.0d0
25615 ! not used by momo potential, but needed by sc_angular which is shared
25616 ! by all energy_potential subroutines
25617           alf1   = 0.0d0
25618           alf2   = 0.0d0
25619           alf12  = 0.0d0
25620           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25621 !       a12sq = a12sq * a12sq
25622 ! charge of amino acid itypi is...
25623           chis1 = chis(itypi,itypj)
25624           chis2 = chis(itypj,itypi)
25625           chis12 = chis1 * chis2
25626           sig1 = sigmap1(itypi,itypj)
25627           sig2 = sigmap2(itypi,itypj)
25628 !       write (*,*) "sig1 = ", sig1
25629 !          chis1=0.0
25630 !          chis2=0.0
25631 !                    chis12 = chis1 * chis2
25632 !          sig1=0.0
25633 !          sig2=0.0
25634 !       write (*,*) "sig2 = ", sig2
25635 ! alpha factors from Fcav/Gcav
25636           b1cav = alphasur(1,itypi,itypj)
25637 !          b1cav=0.0d0
25638           b2cav = alphasur(2,itypi,itypj)
25639           b3cav = alphasur(3,itypi,itypj)
25640           b4cav = alphasur(4,itypi,itypj)
25641 ! used to determine whether we want to do quadrupole calculations
25642        eps_in = epsintab(itypi,itypj)
25643        if (eps_in.eq.0.0) eps_in=1.0
25644
25645        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25646        Rtail = 0.0d0
25647 !       dtail(1,itypi,itypj)=0.0
25648 !       dtail(2,itypi,itypj)=0.0
25649
25650        DO k = 1, 3
25651         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25652         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25653        END DO
25654 !c! tail distances will be themselves usefull elswhere
25655 !c1 (in Gcav, for example)
25656        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25657        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25658        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25659        Rtail = dsqrt( &
25660           (Rtail_distance(1)*Rtail_distance(1)) &
25661         + (Rtail_distance(2)*Rtail_distance(2)) &
25662         + (Rtail_distance(3)*Rtail_distance(3)))
25663
25664 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25665 !-------------------------------------------------------------------
25666 ! tail location and distance calculations
25667        d1 = dhead(1, 1, itypi, itypj)
25668        d2 = dhead(2, 1, itypi, itypj)
25669
25670        DO k = 1,3
25671 ! location of polar head is computed by taking hydrophobic centre
25672 ! and moving by a d1 * dc_norm vector
25673 ! see unres publications for very informative images
25674         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25675         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25676 ! distance
25677 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25678 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25679         Rhead_distance(k) = chead(k,2) - chead(k,1)
25680        END DO
25681 ! pitagoras (root of sum of squares)
25682        Rhead = dsqrt( &
25683           (Rhead_distance(1)*Rhead_distance(1)) &
25684         + (Rhead_distance(2)*Rhead_distance(2)) &
25685         + (Rhead_distance(3)*Rhead_distance(3)))
25686 !-------------------------------------------------------------------
25687 ! zero everything that should be zero'ed
25688        evdwij = 0.0d0
25689        ECL = 0.0d0
25690        Elj = 0.0d0
25691        Equad = 0.0d0
25692        Epol = 0.0d0
25693        Fcav=0.0d0
25694        eheadtail = 0.0d0
25695        dGCLdOM1 = 0.0d0
25696        dGCLdOM2 = 0.0d0
25697        dGCLdOM12 = 0.0d0
25698        dPOLdOM1 = 0.0d0
25699        dPOLdOM2 = 0.0d0
25700           Fcav = 0.0d0
25701           dFdR = 0.0d0
25702           dCAVdOM1  = 0.0d0
25703           dCAVdOM2  = 0.0d0
25704           dCAVdOM12 = 0.0d0
25705           dscj_inv = vbld_inv(j+nres)
25706 !          print *,i,j,dscj_inv,dsci_inv
25707 ! rij holds 1/(distance of Calpha atoms)
25708           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25709           rij  = dsqrt(rrij)
25710 !----------------------------
25711           CALL sc_angular
25712 ! this should be in elgrad_init but om's are calculated by sc_angular
25713 ! which in turn is used by older potentials
25714 ! om = omega, sqom = om^2
25715           sqom1  = om1 * om1
25716           sqom2  = om2 * om2
25717           sqom12 = om12 * om12
25718
25719 ! now we calculate EGB - Gey-Berne
25720 ! It will be summed up in evdwij and saved in evdw
25721           sigsq     = 1.0D0  / sigsq
25722           sig       = sig0ij * dsqrt(sigsq)
25723 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25724           rij_shift = Rtail - sig + sig0ij
25725           IF (rij_shift.le.0.0D0) THEN
25726            evdw = 1.0D20
25727            RETURN
25728           END IF
25729           sigder = -sig * sigsq
25730           rij_shift = 1.0D0 / rij_shift
25731           fac       = rij_shift**expon
25732           c1        = fac  * fac * aa_aq(itypi,itypj)
25733 !          print *,"ADAM",aa_aq(itypi,itypj)
25734
25735 !          c1        = 0.0d0
25736           c2        = fac  * bb_aq(itypi,itypj)
25737 !          c2        = 0.0d0
25738           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25739           eps2der   = eps3rt * evdwij
25740           eps3der   = eps2rt * evdwij
25741 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25742           evdwij    = eps2rt * eps3rt * evdwij
25743 !#ifdef TSCSC
25744 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25745 !           evdw_p = evdw_p + evdwij
25746 !          ELSE
25747 !           evdw_m = evdw_m + evdwij
25748 !          END IF
25749 !#else
25750           evdw = evdw  &
25751               + evdwij
25752 !#endif
25753
25754           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25755           fac    = -expon * (c1 + evdwij) * rij_shift
25756           sigder = fac * sigder
25757 !          fac    = rij * fac
25758 ! Calculate distance derivative
25759           gg(1) =  fac
25760           gg(2) =  fac
25761           gg(3) =  fac
25762 !          if (b2.gt.0.0) then
25763           fac = chis1 * sqom1 + chis2 * sqom2 &
25764           - 2.0d0 * chis12 * om1 * om2 * om12
25765 ! we will use pom later in Gcav, so dont mess with it!
25766           pom = 1.0d0 - chis1 * chis2 * sqom12
25767           Lambf = (1.0d0 - (fac / pom))
25768 !          print *,"fac,pom",fac,pom,Lambf
25769           Lambf = dsqrt(Lambf)
25770           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25771 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25772 !       write (*,*) "sparrow = ", sparrow
25773           Chif = Rtail * sparrow
25774 !           print *,"rij,sparrow",rij , sparrow
25775           ChiLambf = Chif * Lambf
25776           eagle = dsqrt(ChiLambf)
25777           bat = ChiLambf ** 11.0d0
25778           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25779           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25780           botsq = bot * bot
25781 !          print *,top,bot,"bot,top",ChiLambf,Chif
25782           Fcav = top / bot
25783
25784        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25785        dbot = 12.0d0 * b4cav * bat * Lambf
25786        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25787
25788           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25789           dbot = 12.0d0 * b4cav * bat * Chif
25790           eagle = Lambf * pom
25791           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25792           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25793           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25794               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25795
25796           dFdL = ((dtop * bot - top * dbot) / botsq)
25797 !       dFdL = 0.0d0
25798           dCAVdOM1  = dFdL * ( dFdOM1 )
25799           dCAVdOM2  = dFdL * ( dFdOM2 )
25800           dCAVdOM12 = dFdL * ( dFdOM12 )
25801
25802        DO k= 1, 3
25803         ertail(k) = Rtail_distance(k)/Rtail
25804        END DO
25805        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25806        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25807        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25808        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25809        DO k = 1, 3
25810 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25811 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25812         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25813         gvdwx(k,i) = gvdwx(k,i) &
25814                   - (( dFdR + gg(k) ) * pom)
25815 !c!     &             - ( dFdR * pom )
25816         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25817         gvdwx(k,j) = gvdwx(k,j)   &
25818                   + (( dFdR + gg(k) ) * pom)
25819 !c!     &             + ( dFdR * pom )
25820
25821         gvdwc(k,i) = gvdwc(k,i)  &
25822                   - (( dFdR + gg(k) ) * ertail(k))
25823 !c!     &             - ( dFdR * ertail(k))
25824
25825         gvdwc(k,j) = gvdwc(k,j) &
25826                   + (( dFdR + gg(k) ) * ertail(k))
25827 !c!     &             + ( dFdR * ertail(k))
25828
25829         gg(k) = 0.0d0
25830 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25831 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25832       END DO
25833
25834
25835 !c! Compute head-head and head-tail energies for each state
25836
25837           isel = iabs(Qi) + iabs(Qj)
25838 ! double charge for Phophorylated! itype - 25,27,27
25839 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25840 !            Qi=Qi*2
25841 !            Qij=Qij*2
25842 !           endif
25843 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25844 !            Qj=Qj*2
25845 !            Qij=Qij*2
25846 !           endif
25847
25848 !          isel=0
25849           IF (isel.eq.0) THEN
25850 !c! No charges - do nothing
25851            eheadtail = 0.0d0
25852
25853           ELSE IF (isel.eq.4) THEN
25854 !c! Calculate dipole-dipole interactions
25855            CALL edd(ecl)
25856            eheadtail = ECL
25857 !           eheadtail = 0.0d0
25858
25859           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25860 !c! Charge-nonpolar interactions
25861           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25862             Qi=Qi*2
25863             Qij=Qij*2
25864            endif
25865           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25866             Qj=Qj*2
25867             Qij=Qij*2
25868            endif
25869
25870            CALL eqn(epol)
25871            eheadtail = epol
25872 !           eheadtail = 0.0d0
25873
25874           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25875 !c! Nonpolar-charge interactions
25876           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25877             Qi=Qi*2
25878             Qij=Qij*2
25879            endif
25880           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25881             Qj=Qj*2
25882             Qij=Qij*2
25883            endif
25884
25885            CALL enq(epol)
25886            eheadtail = epol
25887 !           eheadtail = 0.0d0
25888
25889           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25890 !c! Charge-dipole interactions
25891           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25892             Qi=Qi*2
25893             Qij=Qij*2
25894            endif
25895           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25896             Qj=Qj*2
25897             Qij=Qij*2
25898            endif
25899
25900            CALL eqd(ecl, elj, epol)
25901            eheadtail = ECL + elj + epol
25902 !           eheadtail = 0.0d0
25903
25904           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25905 !c! Dipole-charge interactions
25906           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25907             Qi=Qi*2
25908             Qij=Qij*2
25909            endif
25910           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25911             Qj=Qj*2
25912             Qij=Qij*2
25913            endif
25914            CALL edq(ecl, elj, epol)
25915           eheadtail = ECL + elj + epol
25916 !           eheadtail = 0.0d0
25917
25918           ELSE IF ((isel.eq.2.and.   &
25919                iabs(Qi).eq.1).and.  &
25920                nstate(itypi,itypj).eq.1) THEN
25921 !c! Same charge-charge interaction ( +/+ or -/- )
25922           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25923             Qi=Qi*2
25924             Qij=Qij*2
25925            endif
25926           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25927             Qj=Qj*2
25928             Qij=Qij*2
25929            endif
25930
25931            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25932            eheadtail = ECL + Egb + Epol + Fisocav + Elj
25933 !           eheadtail = 0.0d0
25934
25935           ELSE IF ((isel.eq.2.and.  &
25936                iabs(Qi).eq.1).and. &
25937                nstate(itypi,itypj).ne.1) THEN
25938 !c! Different charge-charge interaction ( +/- or -/+ )
25939           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25940             Qi=Qi*2
25941             Qij=Qij*2
25942            endif
25943           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25944             Qj=Qj*2
25945             Qij=Qij*2
25946            endif
25947
25948            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25949           END IF
25950        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25951       evdw = evdw  + Fcav + eheadtail
25952
25953        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25954         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25955         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25956         Equad,evdwij+Fcav+eheadtail,evdw
25957 !       evdw = evdw  + Fcav  + eheadtail
25958
25959         iF (nstate(itypi,itypj).eq.1) THEN
25960         CALL sc_grad
25961        END IF
25962 !c!-------------------------------------------------------------------
25963 !c! NAPISY KONCOWE
25964          END DO   ! j
25965         END DO    ! iint
25966        END DO     ! i
25967 !c      write (iout,*) "Number of loop steps in EGB:",ind
25968 !c      energy_dec=.false.
25969 !              print *,"EVDW KURW",evdw,nres
25970
25971        RETURN
25972       END SUBROUTINE emomo
25973 !C------------------------------------------------------------------------------------
25974       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25975       use calc_data
25976       use comm_momo
25977        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25978          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25979 !       integer :: k
25980 !c! Epol and Gpol analytical parameters
25981        alphapol1 = alphapol(itypi,itypj)
25982        alphapol2 = alphapol(itypj,itypi)
25983 !c! Fisocav and Gisocav analytical parameters
25984        al1  = alphiso(1,itypi,itypj)
25985        al2  = alphiso(2,itypi,itypj)
25986        al3  = alphiso(3,itypi,itypj)
25987        al4  = alphiso(4,itypi,itypj)
25988        csig = (1.0d0  &
25989            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25990            + sigiso2(itypi,itypj)**2.0d0))
25991 !c!
25992        pis  = sig0head(itypi,itypj)
25993        eps_head = epshead(itypi,itypj)
25994        Rhead_sq = Rhead * Rhead
25995 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25996 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25997        R1 = 0.0d0
25998        R2 = 0.0d0
25999        DO k = 1, 3
26000 !c! Calculate head-to-tail distances needed by Epol
26001         R1=R1+(ctail(k,2)-chead(k,1))**2
26002         R2=R2+(chead(k,2)-ctail(k,1))**2
26003        END DO
26004 !c! Pitagoras
26005        R1 = dsqrt(R1)
26006        R2 = dsqrt(R2)
26007
26008 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26009 !c!     &        +dhead(1,1,itypi,itypj))**2))
26010 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26011 !c!     &        +dhead(2,1,itypi,itypj))**2))
26012
26013 !c!-------------------------------------------------------------------
26014 !c! Coulomb electrostatic interaction
26015        Ecl = (332.0d0 * Qij) / Rhead
26016 !c! derivative of Ecl is Gcl...
26017        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26018        dGCLdOM1 = 0.0d0
26019        dGCLdOM2 = 0.0d0
26020        dGCLdOM12 = 0.0d0
26021        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26022        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26023        debkap=debaykap(itypi,itypj)
26024        Egb = -(332.0d0 * Qij *&
26025         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26026 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26027 !c! Derivative of Egb is Ggb...
26028        dGGBdFGB = -(-332.0d0 * Qij * &
26029        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26030        -(332.0d0 * Qij *&
26031         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26032        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26033        dGGBdR = dGGBdFGB * dFGBdR
26034 !c!-------------------------------------------------------------------
26035 !c! Fisocav - isotropic cavity creation term
26036 !c! or "how much energy it costs to put charged head in water"
26037        pom = Rhead * csig
26038        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26039        bot = (1.0d0 + al4 * pom**12.0d0)
26040        botsq = bot * bot
26041        FisoCav = top / bot
26042 !      write (*,*) "Rhead = ",Rhead
26043 !      write (*,*) "csig = ",csig
26044 !      write (*,*) "pom = ",pom
26045 !      write (*,*) "al1 = ",al1
26046 !      write (*,*) "al2 = ",al2
26047 !      write (*,*) "al3 = ",al3
26048 !      write (*,*) "al4 = ",al4
26049 !        write (*,*) "top = ",top
26050 !        write (*,*) "bot = ",bot
26051 !c! Derivative of Fisocav is GCV...
26052        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26053        dbot = 12.0d0 * al4 * pom ** 11.0d0
26054        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26055 !c!-------------------------------------------------------------------
26056 !c! Epol
26057 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26058        MomoFac1 = (1.0d0 - chi1 * sqom2)
26059        MomoFac2 = (1.0d0 - chi2 * sqom1)
26060        RR1  = ( R1 * R1 ) / MomoFac1
26061        RR2  = ( R2 * R2 ) / MomoFac2
26062        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26063        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26064        fgb1 = sqrt( RR1 + a12sq * ee1 )
26065        fgb2 = sqrt( RR2 + a12sq * ee2 )
26066        epol = 332.0d0 * eps_inout_fac * ( &
26067       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26068 !c!       epol = 0.0d0
26069        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26070                / (fgb1 ** 5.0d0)
26071        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26072                / (fgb2 ** 5.0d0)
26073        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26074              / ( 2.0d0 * fgb1 )
26075        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26076              / ( 2.0d0 * fgb2 )
26077        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26078                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26079        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26080                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26081        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26082 !c!       dPOLdR1 = 0.0d0
26083        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26084 !c!       dPOLdR2 = 0.0d0
26085        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26086 !c!       dPOLdOM1 = 0.0d0
26087        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26088 !c!       dPOLdOM2 = 0.0d0
26089 !c!-------------------------------------------------------------------
26090 !c! Elj
26091 !c! Lennard-Jones 6-12 interaction between heads
26092        pom = (pis / Rhead)**6.0d0
26093        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26094 !c! derivative of Elj is Glj
26095        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26096              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26097 !c!-------------------------------------------------------------------
26098 !c! Return the results
26099 !c! These things do the dRdX derivatives, that is
26100 !c! allow us to change what we see from function that changes with
26101 !c! distance to function that changes with LOCATION (of the interaction
26102 !c! site)
26103        DO k = 1, 3
26104         erhead(k) = Rhead_distance(k)/Rhead
26105         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26106         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26107        END DO
26108
26109        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26110        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26111        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26112        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26113        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26114        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26115        facd1 = d1 * vbld_inv(i+nres)
26116        facd2 = d2 * vbld_inv(j+nres)
26117        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26118        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26119
26120 !c! Now we add appropriate partial derivatives (one in each dimension)
26121        DO k = 1, 3
26122         hawk   = (erhead_tail(k,1) + &
26123         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26124         condor = (erhead_tail(k,2) + &
26125         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26126
26127         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26128         gvdwx(k,i) = gvdwx(k,i) &
26129                   - dGCLdR * pom&
26130                   - dGGBdR * pom&
26131                   - dGCVdR * pom&
26132                   - dPOLdR1 * hawk&
26133                   - dPOLdR2 * (erhead_tail(k,2)&
26134       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26135                   - dGLJdR * pom
26136
26137         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26138         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26139                    + dGGBdR * pom+ dGCVdR * pom&
26140                   + dPOLdR1 * (erhead_tail(k,1)&
26141       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26142                   + dPOLdR2 * condor + dGLJdR * pom
26143
26144         gvdwc(k,i) = gvdwc(k,i)  &
26145                   - dGCLdR * erhead(k)&
26146                   - dGGBdR * erhead(k)&
26147                   - dGCVdR * erhead(k)&
26148                   - dPOLdR1 * erhead_tail(k,1)&
26149                   - dPOLdR2 * erhead_tail(k,2)&
26150                   - dGLJdR * erhead(k)
26151
26152         gvdwc(k,j) = gvdwc(k,j)         &
26153                   + dGCLdR * erhead(k) &
26154                   + dGGBdR * erhead(k) &
26155                   + dGCVdR * erhead(k) &
26156                   + dPOLdR1 * erhead_tail(k,1) &
26157                   + dPOLdR2 * erhead_tail(k,2)&
26158                   + dGLJdR * erhead(k)
26159
26160        END DO
26161        RETURN
26162       END SUBROUTINE eqq
26163
26164       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26165       use calc_data
26166       use comm_momo
26167        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26168          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26169 !       integer :: k
26170 !c! Epol and Gpol analytical parameters
26171        alphapol1 = alphapolcat(itypi,itypj)
26172        alphapol2 = alphapolcat(itypj,itypi)
26173 !c! Fisocav and Gisocav analytical parameters
26174        al1  = alphisocat(1,itypi,itypj)
26175        al2  = alphisocat(2,itypi,itypj)
26176        al3  = alphisocat(3,itypi,itypj)
26177        al4  = alphisocat(4,itypi,itypj)
26178        csig = (1.0d0  &
26179            / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26180            + sigiso2cat(itypi,itypj)**2.0d0))
26181 !c!
26182        pis  = sig0headcat(itypi,itypj)
26183        eps_head = epsheadcat(itypi,itypj)
26184        Rhead_sq = Rhead * Rhead
26185 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26186 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26187        R1 = 0.0d0
26188        R2 = 0.0d0
26189        DO k = 1, 3
26190 !c! Calculate head-to-tail distances needed by Epol
26191         R1=R1+(ctail(k,2)-chead(k,1))**2
26192         R2=R2+(chead(k,2)-ctail(k,1))**2
26193        END DO
26194 !c! Pitagoras
26195        R1 = dsqrt(R1)
26196        R2 = dsqrt(R2)
26197
26198 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26199 !c!     &        +dhead(1,1,itypi,itypj))**2))
26200 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26201 !c!     &        +dhead(2,1,itypi,itypj))**2))
26202
26203 !c!-------------------------------------------------------------------
26204 !c! Coulomb electrostatic interaction
26205        Ecl = (332.0d0 * Qij) / Rhead
26206 !c! derivative of Ecl is Gcl...
26207        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26208        dGCLdOM1 = 0.0d0
26209        dGCLdOM2 = 0.0d0
26210        dGCLdOM12 = 0.0d0
26211        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26212        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26213        debkap=debaykapcat(itypi,itypj)
26214        Egb = -(332.0d0 * Qij *&
26215         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26216 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26217 !c! Derivative of Egb is Ggb...
26218        dGGBdFGB = -(-332.0d0 * Qij * &
26219        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26220        -(332.0d0 * Qij *&
26221         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26222        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26223        dGGBdR = dGGBdFGB * dFGBdR
26224 !c!-------------------------------------------------------------------
26225 !c! Fisocav - isotropic cavity creation term
26226 !c! or "how much energy it costs to put charged head in water"
26227        pom = Rhead * csig
26228        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26229        bot = (1.0d0 + al4 * pom**12.0d0)
26230        botsq = bot * bot
26231        FisoCav = top / bot
26232 !      write (*,*) "Rhead = ",Rhead
26233 !      write (*,*) "csig = ",csig
26234 !      write (*,*) "pom = ",pom
26235 !      write (*,*) "al1 = ",al1
26236 !      write (*,*) "al2 = ",al2
26237 !      write (*,*) "al3 = ",al3
26238 !      write (*,*) "al4 = ",al4
26239 !        write (*,*) "top = ",top
26240 !        write (*,*) "bot = ",bot
26241 !c! Derivative of Fisocav is GCV...
26242        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26243        dbot = 12.0d0 * al4 * pom ** 11.0d0
26244        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26245 !c!-------------------------------------------------------------------
26246 !c! Epol
26247 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26248        MomoFac1 = (1.0d0 - chi1 * sqom2)
26249        MomoFac2 = (1.0d0 - chi2 * sqom1)
26250        RR1  = ( R1 * R1 ) / MomoFac1
26251        RR2  = ( R2 * R2 ) / MomoFac2
26252        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26253        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26254        fgb1 = sqrt( RR1 + a12sq * ee1 )
26255        fgb2 = sqrt( RR2 + a12sq * ee2 )
26256        epol = 332.0d0 * eps_inout_fac * ( &
26257       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26258 !c!       epol = 0.0d0
26259        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26260                / (fgb1 ** 5.0d0)
26261        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26262                / (fgb2 ** 5.0d0)
26263        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26264              / ( 2.0d0 * fgb1 )
26265        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26266              / ( 2.0d0 * fgb2 )
26267        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26268                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26269        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26270                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26271        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26272 !c!       dPOLdR1 = 0.0d0
26273        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26274 !c!       dPOLdR2 = 0.0d0
26275        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26276 !c!       dPOLdOM1 = 0.0d0
26277        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26278 !c!       dPOLdOM2 = 0.0d0
26279 !c!-------------------------------------------------------------------
26280 !c! Elj
26281 !c! Lennard-Jones 6-12 interaction between heads
26282        pom = (pis / Rhead)**6.0d0
26283        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26284 !c! derivative of Elj is Glj
26285        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26286              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26287 !c!-------------------------------------------------------------------
26288 !c! Return the results
26289 !c! These things do the dRdX derivatives, that is
26290 !c! allow us to change what we see from function that changes with
26291 !c! distance to function that changes with LOCATION (of the interaction
26292 !c! site)
26293        DO k = 1, 3
26294         erhead(k) = Rhead_distance(k)/Rhead
26295         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26296         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26297        END DO
26298
26299        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26300        erdxj = scalar( erhead(1), dC_norm(1,j) )
26301        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26302        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26303        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26304        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26305        facd1 = d1 * vbld_inv(i+nres)
26306        facd2 = d2 * vbld_inv(j)
26307        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26308        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26309
26310 !c! Now we add appropriate partial derivatives (one in each dimension)
26311        DO k = 1, 3
26312         hawk   = (erhead_tail(k,1) + &
26313         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26314         condor = (erhead_tail(k,2) + &
26315         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26316
26317         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26318         gradpepcatx(k,i) = gradpepcatx(k,i) &
26319                   - dGCLdR * pom&
26320                   - dGGBdR * pom&
26321                   - dGCVdR * pom&
26322                   - dPOLdR1 * hawk&
26323                   - dPOLdR2 * (erhead_tail(k,2)&
26324       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26325                   - dGLJdR * pom
26326
26327         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26328 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26329 !                   + dGGBdR * pom+ dGCVdR * pom&
26330 !                  + dPOLdR1 * (erhead_tail(k,1)&
26331 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26332 !                  + dPOLdR2 * condor + dGLJdR * pom
26333
26334         gradpepcat(k,i) = gradpepcat(k,i)  &
26335                   - dGCLdR * erhead(k)&
26336                   - dGGBdR * erhead(k)&
26337                   - dGCVdR * erhead(k)&
26338                   - dPOLdR1 * erhead_tail(k,1)&
26339                   - dPOLdR2 * erhead_tail(k,2)&
26340                   - dGLJdR * erhead(k)
26341
26342         gradpepcat(k,j) = gradpepcat(k,j)         &
26343                   + dGCLdR * erhead(k) &
26344                   + dGGBdR * erhead(k) &
26345                   + dGCVdR * erhead(k) &
26346                   + dPOLdR1 * erhead_tail(k,1) &
26347                   + dPOLdR2 * erhead_tail(k,2)&
26348                   + dGLJdR * erhead(k)
26349
26350        END DO
26351        RETURN
26352       END SUBROUTINE eqq_cat
26353 !c!-------------------------------------------------------------------
26354       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26355       use comm_momo
26356       use calc_data
26357
26358        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26359        double precision ener(4)
26360        double precision dcosom1(3),dcosom2(3)
26361 !c! used in Epol derivatives
26362        double precision facd3, facd4
26363        double precision federmaus, adler
26364        integer istate,ii,jj
26365        real (kind=8) :: Fgb
26366 !       print *,"CALLING EQUAD"
26367 !c! Epol and Gpol analytical parameters
26368        alphapol1 = alphapol(itypi,itypj)
26369        alphapol2 = alphapol(itypj,itypi)
26370 !c! Fisocav and Gisocav analytical parameters
26371        al1  = alphiso(1,itypi,itypj)
26372        al2  = alphiso(2,itypi,itypj)
26373        al3  = alphiso(3,itypi,itypj)
26374        al4  = alphiso(4,itypi,itypj)
26375        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26376             + sigiso2(itypi,itypj)**2.0d0))
26377 !c!
26378        w1   = wqdip(1,itypi,itypj)
26379        w2   = wqdip(2,itypi,itypj)
26380        pis  = sig0head(itypi,itypj)
26381        eps_head = epshead(itypi,itypj)
26382 !c! First things first:
26383 !c! We need to do sc_grad's job with GB and Fcav
26384        eom1  = eps2der * eps2rt_om1 &
26385              - 2.0D0 * alf1 * eps3der&
26386              + sigder * sigsq_om1&
26387              + dCAVdOM1
26388        eom2  = eps2der * eps2rt_om2 &
26389              + 2.0D0 * alf2 * eps3der&
26390              + sigder * sigsq_om2&
26391              + dCAVdOM2
26392        eom12 =  evdwij  * eps1_om12 &
26393              + eps2der * eps2rt_om12 &
26394              - 2.0D0 * alf12 * eps3der&
26395              + sigder *sigsq_om12&
26396              + dCAVdOM12
26397 !c! now some magical transformations to project gradient into
26398 !c! three cartesian vectors
26399        DO k = 1, 3
26400         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26401         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26402         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26403 !c! this acts on hydrophobic center of interaction
26404         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26405                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26406                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26407         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26408                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26409                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26410 !c! this acts on Calpha
26411         gvdwc(k,i)=gvdwc(k,i)-gg(k)
26412         gvdwc(k,j)=gvdwc(k,j)+gg(k)
26413        END DO
26414 !c! sc_grad is done, now we will compute
26415        eheadtail = 0.0d0
26416        eom1 = 0.0d0
26417        eom2 = 0.0d0
26418        eom12 = 0.0d0
26419        DO istate = 1, nstate(itypi,itypj)
26420 !c*************************************************************
26421         IF (istate.ne.1) THEN
26422          IF (istate.lt.3) THEN
26423           ii = 1
26424          ELSE
26425           ii = 2
26426          END IF
26427         jj = istate/ii
26428         d1 = dhead(1,ii,itypi,itypj)
26429         d2 = dhead(2,jj,itypi,itypj)
26430         DO k = 1,3
26431          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26432          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26433          Rhead_distance(k) = chead(k,2) - chead(k,1)
26434         END DO
26435 !c! pitagoras (root of sum of squares)
26436         Rhead = dsqrt( &
26437                (Rhead_distance(1)*Rhead_distance(1))  &
26438              + (Rhead_distance(2)*Rhead_distance(2))  &
26439              + (Rhead_distance(3)*Rhead_distance(3)))
26440         END IF
26441         Rhead_sq = Rhead * Rhead
26442
26443 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26444 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26445         R1 = 0.0d0
26446         R2 = 0.0d0
26447         DO k = 1, 3
26448 !c! Calculate head-to-tail distances
26449          R1=R1+(ctail(k,2)-chead(k,1))**2
26450          R2=R2+(chead(k,2)-ctail(k,1))**2
26451         END DO
26452 !c! Pitagoras
26453         R1 = dsqrt(R1)
26454         R2 = dsqrt(R2)
26455         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26456 !c!        Ecl = 0.0d0
26457 !c!        write (*,*) "Ecl = ", Ecl
26458 !c! derivative of Ecl is Gcl...
26459         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26460 !c!        dGCLdR = 0.0d0
26461         dGCLdOM1 = 0.0d0
26462         dGCLdOM2 = 0.0d0
26463         dGCLdOM12 = 0.0d0
26464 !c!-------------------------------------------------------------------
26465 !c! Generalised Born Solvent Polarization
26466         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26467         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26468         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26469 !c!        Egb = 0.0d0
26470 !c!      write (*,*) "a1*a2 = ", a12sq
26471 !c!      write (*,*) "Rhead = ", Rhead
26472 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26473 !c!      write (*,*) "ee = ", ee
26474 !c!      write (*,*) "Fgb = ", Fgb
26475 !c!      write (*,*) "fac = ", eps_inout_fac
26476 !c!      write (*,*) "Qij = ", Qij
26477 !c!      write (*,*) "Egb = ", Egb
26478 !c! Derivative of Egb is Ggb...
26479 !c! dFGBdR is used by Quad's later...
26480         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26481         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26482                / ( 2.0d0 * Fgb )
26483         dGGBdR = dGGBdFGB * dFGBdR
26484 !c!        dGGBdR = 0.0d0
26485 !c!-------------------------------------------------------------------
26486 !c! Fisocav - isotropic cavity creation term
26487         pom = Rhead * csig
26488         top = al1 * (dsqrt(pom) + al2 * pom - al3)
26489         bot = (1.0d0 + al4 * pom**12.0d0)
26490         botsq = bot * bot
26491         FisoCav = top / bot
26492         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26493         dbot = 12.0d0 * al4 * pom ** 11.0d0
26494         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26495 !c!        dGCVdR = 0.0d0
26496 !c!-------------------------------------------------------------------
26497 !c! Polarization energy
26498 !c! Epol
26499         MomoFac1 = (1.0d0 - chi1 * sqom2)
26500         MomoFac2 = (1.0d0 - chi2 * sqom1)
26501         RR1  = ( R1 * R1 ) / MomoFac1
26502         RR2  = ( R2 * R2 ) / MomoFac2
26503         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26504         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26505         fgb1 = sqrt( RR1 + a12sq * ee1 )
26506         fgb2 = sqrt( RR2 + a12sq * ee2 )
26507         epol = 332.0d0 * eps_inout_fac * (&
26508         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26509 !c!        epol = 0.0d0
26510 !c! derivative of Epol is Gpol...
26511         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26512                   / (fgb1 ** 5.0d0)
26513         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26514                   / (fgb2 ** 5.0d0)
26515         dFGBdR1 = ( (R1 / MomoFac1) &
26516                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
26517                 / ( 2.0d0 * fgb1 )
26518         dFGBdR2 = ( (R2 / MomoFac2) &
26519                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26520                 / ( 2.0d0 * fgb2 )
26521         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26522                  * ( 2.0d0 - 0.5d0 * ee1) ) &
26523                  / ( 2.0d0 * fgb1 )
26524         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26525                  * ( 2.0d0 - 0.5d0 * ee2) ) &
26526                  / ( 2.0d0 * fgb2 )
26527         dPOLdR1 = dPOLdFGB1 * dFGBdR1
26528 !c!        dPOLdR1 = 0.0d0
26529         dPOLdR2 = dPOLdFGB2 * dFGBdR2
26530 !c!        dPOLdR2 = 0.0d0
26531         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26532 !c!        dPOLdOM1 = 0.0d0
26533         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26534         pom = (pis / Rhead)**6.0d0
26535         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26536 !c!        Elj = 0.0d0
26537 !c! derivative of Elj is Glj
26538         dGLJdR = 4.0d0 * eps_head &
26539             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26540             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26541 !c!        dGLJdR = 0.0d0
26542 !c!-------------------------------------------------------------------
26543 !c! Equad
26544        IF (Wqd.ne.0.0d0) THEN
26545         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26546              - 37.5d0  * ( sqom1 + sqom2 ) &
26547              + 157.5d0 * ( sqom1 * sqom2 ) &
26548              - 45.0d0  * om1*om2*om12
26549         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26550         Equad = fac * Beta1
26551 !c!        Equad = 0.0d0
26552 !c! derivative of Equad...
26553         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26554 !c!        dQUADdR = 0.0d0
26555         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26556 !c!        dQUADdOM1 = 0.0d0
26557         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26558 !c!        dQUADdOM2 = 0.0d0
26559         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26560        ELSE
26561          Beta1 = 0.0d0
26562          Equad = 0.0d0
26563         END IF
26564 !c!-------------------------------------------------------------------
26565 !c! Return the results
26566 !c! Angular stuff
26567         eom1 = dPOLdOM1 + dQUADdOM1
26568         eom2 = dPOLdOM2 + dQUADdOM2
26569         eom12 = dQUADdOM12
26570 !c! now some magical transformations to project gradient into
26571 !c! three cartesian vectors
26572         DO k = 1, 3
26573          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26574          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26575          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26576         END DO
26577 !c! Radial stuff
26578         DO k = 1, 3
26579          erhead(k) = Rhead_distance(k)/Rhead
26580          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26581          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26582         END DO
26583         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26584         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26585         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26586         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26587         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26588         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26589         facd1 = d1 * vbld_inv(i+nres)
26590         facd2 = d2 * vbld_inv(j+nres)
26591         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26592         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26593         DO k = 1, 3
26594          hawk   = erhead_tail(k,1) + &
26595          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26596          condor = erhead_tail(k,2) + &
26597          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26598
26599          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26600 !c! this acts on hydrophobic center of interaction
26601          gheadtail(k,1,1) = gheadtail(k,1,1) &
26602                          - dGCLdR * pom &
26603                          - dGGBdR * pom &
26604                          - dGCVdR * pom &
26605                          - dPOLdR1 * hawk &
26606                          - dPOLdR2 * (erhead_tail(k,2) &
26607       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26608                          - dGLJdR * pom &
26609                          - dQUADdR * pom&
26610                          - tuna(k) &
26611                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26612                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26613
26614          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26615 !c! this acts on hydrophobic center of interaction
26616          gheadtail(k,2,1) = gheadtail(k,2,1)  &
26617                          + dGCLdR * pom      &
26618                          + dGGBdR * pom      &
26619                          + dGCVdR * pom      &
26620                          + dPOLdR1 * (erhead_tail(k,1) &
26621       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26622                          + dPOLdR2 * condor &
26623                          + dGLJdR * pom &
26624                          + dQUADdR * pom &
26625                          + tuna(k) &
26626                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26627                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26628
26629 !c! this acts on Calpha
26630          gheadtail(k,3,1) = gheadtail(k,3,1)  &
26631                          - dGCLdR * erhead(k)&
26632                          - dGGBdR * erhead(k)&
26633                          - dGCVdR * erhead(k)&
26634                          - dPOLdR1 * erhead_tail(k,1)&
26635                          - dPOLdR2 * erhead_tail(k,2)&
26636                          - dGLJdR * erhead(k) &
26637                          - dQUADdR * erhead(k)&
26638                          - tuna(k)
26639 !c! this acts on Calpha
26640          gheadtail(k,4,1) = gheadtail(k,4,1)   &
26641                           + dGCLdR * erhead(k) &
26642                           + dGGBdR * erhead(k) &
26643                           + dGCVdR * erhead(k) &
26644                           + dPOLdR1 * erhead_tail(k,1) &
26645                           + dPOLdR2 * erhead_tail(k,2) &
26646                           + dGLJdR * erhead(k) &
26647                           + dQUADdR * erhead(k)&
26648                           + tuna(k)
26649         END DO
26650         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26651         eheadtail = eheadtail &
26652                   + wstate(istate, itypi, itypj) &
26653                   * dexp(-betaT * ener(istate))
26654 !c! foreach cartesian dimension
26655         DO k = 1, 3
26656 !c! foreach of two gvdwx and gvdwc
26657          DO l = 1, 4
26658           gheadtail(k,l,2) = gheadtail(k,l,2)  &
26659                            + wstate( istate, itypi, itypj ) &
26660                            * dexp(-betaT * ener(istate)) &
26661                            * gheadtail(k,l,1)
26662           gheadtail(k,l,1) = 0.0d0
26663          END DO
26664         END DO
26665        END DO
26666 !c! Here ended the gigantic DO istate = 1, 4, which starts
26667 !c! at the beggining of the subroutine
26668
26669        DO k = 1, 3
26670         DO l = 1, 4
26671          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26672         END DO
26673         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26674         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26675         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26676         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26677         DO l = 1, 4
26678          gheadtail(k,l,1) = 0.0d0
26679          gheadtail(k,l,2) = 0.0d0
26680         END DO
26681        END DO
26682        eheadtail = (-dlog(eheadtail)) / betaT
26683        dPOLdOM1 = 0.0d0
26684        dPOLdOM2 = 0.0d0
26685        dQUADdOM1 = 0.0d0
26686        dQUADdOM2 = 0.0d0
26687        dQUADdOM12 = 0.0d0
26688        RETURN
26689       END SUBROUTINE energy_quad
26690 !!-----------------------------------------------------------
26691       SUBROUTINE eqn(Epol)
26692       use comm_momo
26693       use calc_data
26694
26695       double precision  facd4, federmaus,epol
26696       alphapol1 = alphapol(itypi,itypj)
26697 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26698        R1 = 0.0d0
26699        DO k = 1, 3
26700 !c! Calculate head-to-tail distances
26701         R1=R1+(ctail(k,2)-chead(k,1))**2
26702        END DO
26703 !c! Pitagoras
26704        R1 = dsqrt(R1)
26705
26706 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26707 !c!     &        +dhead(1,1,itypi,itypj))**2))
26708 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26709 !c!     &        +dhead(2,1,itypi,itypj))**2))
26710 !c--------------------------------------------------------------------
26711 !c Polarization energy
26712 !c Epol
26713        MomoFac1 = (1.0d0 - chi1 * sqom2)
26714        RR1  = R1 * R1 / MomoFac1
26715        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26716        fgb1 = sqrt( RR1 + a12sq * ee1)
26717        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26718        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26719                / (fgb1 ** 5.0d0)
26720        dFGBdR1 = ( (R1 / MomoFac1) &
26721               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26722               / ( 2.0d0 * fgb1 )
26723        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26724                 * (2.0d0 - 0.5d0 * ee1) ) &
26725                 / (2.0d0 * fgb1)
26726        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26727 !c!       dPOLdR1 = 0.0d0
26728        dPOLdOM1 = 0.0d0
26729        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26730        DO k = 1, 3
26731         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26732        END DO
26733        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26734        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26735        facd1 = d1 * vbld_inv(i+nres)
26736        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26737
26738        DO k = 1, 3
26739         hawk = (erhead_tail(k,1) + &
26740         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26741
26742         gvdwx(k,i) = gvdwx(k,i) &
26743                    - dPOLdR1 * hawk
26744         gvdwx(k,j) = gvdwx(k,j) &
26745                    + dPOLdR1 * (erhead_tail(k,1) &
26746        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26747
26748         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26749         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26750
26751        END DO
26752        RETURN
26753       END SUBROUTINE eqn
26754       SUBROUTINE enq(Epol)
26755       use calc_data
26756       use comm_momo
26757        double precision facd3, adler,epol
26758        alphapol2 = alphapol(itypj,itypi)
26759 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26760        R2 = 0.0d0
26761        DO k = 1, 3
26762 !c! Calculate head-to-tail distances
26763         R2=R2+(chead(k,2)-ctail(k,1))**2
26764        END DO
26765 !c! Pitagoras
26766        R2 = dsqrt(R2)
26767
26768 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26769 !c!     &        +dhead(1,1,itypi,itypj))**2))
26770 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26771 !c!     &        +dhead(2,1,itypi,itypj))**2))
26772 !c------------------------------------------------------------------------
26773 !c Polarization energy
26774        MomoFac2 = (1.0d0 - chi2 * sqom1)
26775        RR2  = R2 * R2 / MomoFac2
26776        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26777        fgb2 = sqrt(RR2  + a12sq * ee2)
26778        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26779        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26780                 / (fgb2 ** 5.0d0)
26781        dFGBdR2 = ( (R2 / MomoFac2)  &
26782               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26783               / (2.0d0 * fgb2)
26784        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26785                 * (2.0d0 - 0.5d0 * ee2) ) &
26786                 / (2.0d0 * fgb2)
26787        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26788 !c!       dPOLdR2 = 0.0d0
26789        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26790 !c!       dPOLdOM1 = 0.0d0
26791        dPOLdOM2 = 0.0d0
26792 !c!-------------------------------------------------------------------
26793 !c! Return the results
26794 !c! (See comments in Eqq)
26795        DO k = 1, 3
26796         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26797        END DO
26798        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26799        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26800        facd2 = d2 * vbld_inv(j+nres)
26801        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26802        DO k = 1, 3
26803         condor = (erhead_tail(k,2) &
26804        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26805
26806         gvdwx(k,i) = gvdwx(k,i) &
26807                    - dPOLdR2 * (erhead_tail(k,2) &
26808        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26809         gvdwx(k,j) = gvdwx(k,j)   &
26810                    + dPOLdR2 * condor
26811
26812         gvdwc(k,i) = gvdwc(k,i) &
26813                    - dPOLdR2 * erhead_tail(k,2)
26814         gvdwc(k,j) = gvdwc(k,j) &
26815                    + dPOLdR2 * erhead_tail(k,2)
26816
26817        END DO
26818       RETURN
26819       END SUBROUTINE enq
26820
26821       SUBROUTINE enq_cat(Epol)
26822       use calc_data
26823       use comm_momo
26824        double precision facd3, adler,epol
26825        alphapol2 = alphapolcat(itypj,itypi)
26826 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26827        R2 = 0.0d0
26828        DO k = 1, 3
26829 !c! Calculate head-to-tail distances
26830         R2=R2+(chead(k,2)-ctail(k,1))**2
26831        END DO
26832 !c! Pitagoras
26833        R2 = dsqrt(R2)
26834
26835 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26836 !c!     &        +dhead(1,1,itypi,itypj))**2))
26837 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26838 !c!     &        +dhead(2,1,itypi,itypj))**2))
26839 !c------------------------------------------------------------------------
26840 !c Polarization energy
26841        MomoFac2 = (1.0d0 - chi2 * sqom1)
26842        RR2  = R2 * R2 / MomoFac2
26843        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26844        fgb2 = sqrt(RR2  + a12sq * ee2)
26845        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26846        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26847                 / (fgb2 ** 5.0d0)
26848        dFGBdR2 = ( (R2 / MomoFac2)  &
26849               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26850               / (2.0d0 * fgb2)
26851        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26852                 * (2.0d0 - 0.5d0 * ee2) ) &
26853                 / (2.0d0 * fgb2)
26854        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26855 !c!       dPOLdR2 = 0.0d0
26856        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26857 !c!       dPOLdOM1 = 0.0d0
26858        dPOLdOM2 = 0.0d0
26859
26860 !c!-------------------------------------------------------------------
26861 !c! Return the results
26862 !c! (See comments in Eqq)
26863        DO k = 1, 3
26864         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26865        END DO
26866        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26867        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26868        facd2 = d2 * vbld_inv(j+nres)
26869        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26870        DO k = 1, 3
26871         condor = (erhead_tail(k,2) &
26872        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26873
26874         gradpepcatx(k,i) = gradpepcatx(k,i) &
26875                    - dPOLdR2 * (erhead_tail(k,2) &
26876        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26877 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
26878 !                   + dPOLdR2 * condor
26879
26880         gradpepcat(k,i) = gradpepcat(k,i) &
26881                    - dPOLdR2 * erhead_tail(k,2)
26882         gradpepcat(k,j) = gradpepcat(k,j) &
26883                    + dPOLdR2 * erhead_tail(k,2)
26884
26885        END DO
26886       RETURN
26887       END SUBROUTINE enq_cat
26888
26889       SUBROUTINE eqd(Ecl,Elj,Epol)
26890       use calc_data
26891       use comm_momo
26892        double precision  facd4, federmaus,ecl,elj,epol
26893        alphapol1 = alphapol(itypi,itypj)
26894        w1        = wqdip(1,itypi,itypj)
26895        w2        = wqdip(2,itypi,itypj)
26896        pis       = sig0head(itypi,itypj)
26897        eps_head   = epshead(itypi,itypj)
26898 !c!-------------------------------------------------------------------
26899 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26900        R1 = 0.0d0
26901        DO k = 1, 3
26902 !c! Calculate head-to-tail distances
26903         R1=R1+(ctail(k,2)-chead(k,1))**2
26904        END DO
26905 !c! Pitagoras
26906        R1 = dsqrt(R1)
26907
26908 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26909 !c!     &        +dhead(1,1,itypi,itypj))**2))
26910 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26911 !c!     &        +dhead(2,1,itypi,itypj))**2))
26912
26913 !c!-------------------------------------------------------------------
26914 !c! ecl
26915        sparrow  = w1 * Qi * om1
26916        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26917        Ecl = sparrow / Rhead**2.0d0 &
26918            - hawk    / Rhead**4.0d0
26919        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26920                  + 4.0d0 * hawk    / Rhead**5.0d0
26921 !c! dF/dom1
26922        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26923 !c! dF/dom2
26924        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26925 !c--------------------------------------------------------------------
26926 !c Polarization energy
26927 !c Epol
26928        MomoFac1 = (1.0d0 - chi1 * sqom2)
26929        RR1  = R1 * R1 / MomoFac1
26930        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26931        fgb1 = sqrt( RR1 + a12sq * ee1)
26932        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26933 !c!       epol = 0.0d0
26934 !c!------------------------------------------------------------------
26935 !c! derivative of Epol is Gpol...
26936        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26937                / (fgb1 ** 5.0d0)
26938        dFGBdR1 = ( (R1 / MomoFac1)  &
26939              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26940              / ( 2.0d0 * fgb1 )
26941        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26942                * (2.0d0 - 0.5d0 * ee1) ) &
26943                / (2.0d0 * fgb1)
26944        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26945 !c!       dPOLdR1 = 0.0d0
26946        dPOLdOM1 = 0.0d0
26947        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26948 !c!       dPOLdOM2 = 0.0d0
26949 !c!-------------------------------------------------------------------
26950 !c! Elj
26951        pom = (pis / Rhead)**6.0d0
26952        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26953 !c! derivative of Elj is Glj
26954        dGLJdR = 4.0d0 * eps_head &
26955           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26956           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26957        DO k = 1, 3
26958         erhead(k) = Rhead_distance(k)/Rhead
26959         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26960        END DO
26961
26962        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26963        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26964        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26965        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26966        facd1 = d1 * vbld_inv(i+nres)
26967        facd2 = d2 * vbld_inv(j+nres)
26968        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26969
26970        DO k = 1, 3
26971         hawk = (erhead_tail(k,1) +  &
26972         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26973
26974         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26975         gvdwx(k,i) = gvdwx(k,i)  &
26976                    - dGCLdR * pom&
26977                    - dPOLdR1 * hawk &
26978                    - dGLJdR * pom
26979
26980         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26981         gvdwx(k,j) = gvdwx(k,j)    &
26982                    + dGCLdR * pom  &
26983                    + dPOLdR1 * (erhead_tail(k,1) &
26984        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26985                    + dGLJdR * pom
26986
26987
26988         gvdwc(k,i) = gvdwc(k,i)          &
26989                    - dGCLdR * erhead(k)  &
26990                    - dPOLdR1 * erhead_tail(k,1) &
26991                    - dGLJdR * erhead(k)
26992
26993         gvdwc(k,j) = gvdwc(k,j)          &
26994                    + dGCLdR * erhead(k)  &
26995                    + dPOLdR1 * erhead_tail(k,1) &
26996                    + dGLJdR * erhead(k)
26997
26998        END DO
26999        RETURN
27000       END SUBROUTINE eqd
27001       SUBROUTINE edq(Ecl,Elj,Epol)
27002 !       IMPLICIT NONE
27003        use comm_momo
27004       use calc_data
27005
27006       double precision  facd3, adler,ecl,elj,epol
27007        alphapol2 = alphapol(itypj,itypi)
27008        w1        = wqdip(1,itypi,itypj)
27009        w2        = wqdip(2,itypi,itypj)
27010        pis       = sig0head(itypi,itypj)
27011        eps_head  = epshead(itypi,itypj)
27012 !c!-------------------------------------------------------------------
27013 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27014        R2 = 0.0d0
27015        DO k = 1, 3
27016 !c! Calculate head-to-tail distances
27017         R2=R2+(chead(k,2)-ctail(k,1))**2
27018        END DO
27019 !c! Pitagoras
27020        R2 = dsqrt(R2)
27021
27022 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27023 !c!     &        +dhead(1,1,itypi,itypj))**2))
27024 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27025 !c!     &        +dhead(2,1,itypi,itypj))**2))
27026
27027
27028 !c!-------------------------------------------------------------------
27029 !c! ecl
27030        sparrow  = w1 * Qj * om1
27031        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27032        ECL = sparrow / Rhead**2.0d0 &
27033            - hawk    / Rhead**4.0d0
27034 !c!-------------------------------------------------------------------
27035 !c! derivative of ecl is Gcl
27036 !c! dF/dr part
27037        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27038                  + 4.0d0 * hawk    / Rhead**5.0d0
27039 !c! dF/dom1
27040        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27041 !c! dF/dom2
27042        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27043 !c--------------------------------------------------------------------
27044 !c Polarization energy
27045 !c Epol
27046        MomoFac2 = (1.0d0 - chi2 * sqom1)
27047        RR2  = R2 * R2 / MomoFac2
27048        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27049        fgb2 = sqrt(RR2  + a12sq * ee2)
27050        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27051        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27052                / (fgb2 ** 5.0d0)
27053        dFGBdR2 = ( (R2 / MomoFac2)  &
27054                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27055                / (2.0d0 * fgb2)
27056        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27057                 * (2.0d0 - 0.5d0 * ee2) ) &
27058                 / (2.0d0 * fgb2)
27059        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27060 !c!       dPOLdR2 = 0.0d0
27061        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27062 !c!       dPOLdOM1 = 0.0d0
27063        dPOLdOM2 = 0.0d0
27064 !c!-------------------------------------------------------------------
27065 !c! Elj
27066        pom = (pis / Rhead)**6.0d0
27067        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27068 !c! derivative of Elj is Glj
27069        dGLJdR = 4.0d0 * eps_head &
27070            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27071            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27072 !c!-------------------------------------------------------------------
27073 !c! Return the results
27074 !c! (see comments in Eqq)
27075        DO k = 1, 3
27076         erhead(k) = Rhead_distance(k)/Rhead
27077         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27078        END DO
27079        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27080        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27081        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27082        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27083        facd1 = d1 * vbld_inv(i+nres)
27084        facd2 = d2 * vbld_inv(j+nres)
27085        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27086        DO k = 1, 3
27087         condor = (erhead_tail(k,2) &
27088        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27089
27090         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27091         gvdwx(k,i) = gvdwx(k,i) &
27092                   - dGCLdR * pom &
27093                   - dPOLdR2 * (erhead_tail(k,2) &
27094        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27095                   - dGLJdR * pom
27096
27097         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27098         gvdwx(k,j) = gvdwx(k,j) &
27099                   + dGCLdR * pom &
27100                   + dPOLdR2 * condor &
27101                   + dGLJdR * pom
27102
27103
27104         gvdwc(k,i) = gvdwc(k,i) &
27105                   - dGCLdR * erhead(k) &
27106                   - dPOLdR2 * erhead_tail(k,2) &
27107                   - dGLJdR * erhead(k)
27108
27109         gvdwc(k,j) = gvdwc(k,j) &
27110                   + dGCLdR * erhead(k) &
27111                   + dPOLdR2 * erhead_tail(k,2) &
27112                   + dGLJdR * erhead(k)
27113
27114        END DO
27115        RETURN
27116       END SUBROUTINE edq
27117
27118       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27119       use comm_momo
27120       use calc_data
27121
27122       double precision  facd3, adler,ecl,elj,epol
27123        alphapol2 = alphapolcat(itypj,itypi)
27124        w1        = wqdipcat(1,itypi,itypj)
27125        w2        = wqdipcat(2,itypi,itypj)
27126        pis       = sig0headcat(itypi,itypj)
27127        eps_head  = epsheadcat(itypi,itypj)
27128 !c!-------------------------------------------------------------------
27129 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27130        R2 = 0.0d0
27131        DO k = 1, 3
27132 !c! Calculate head-to-tail distances
27133         R2=R2+(chead(k,2)-ctail(k,1))**2
27134        END DO
27135 !c! Pitagoras
27136        R2 = dsqrt(R2)
27137
27138 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27139 !c!     &        +dhead(1,1,itypi,itypj))**2))
27140 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27141 !c!     &        +dhead(2,1,itypi,itypj))**2))
27142
27143
27144 !c!-------------------------------------------------------------------
27145 !c! ecl
27146        write(iout,*) "KURWA2",Rhead
27147        sparrow  = w1 * Qj * om1
27148        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27149        ECL = sparrow / Rhead**2.0d0 &
27150            - hawk    / Rhead**4.0d0
27151 !c!-------------------------------------------------------------------
27152 !c! derivative of ecl is Gcl
27153 !c! dF/dr part
27154        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27155                  + 4.0d0 * hawk    / Rhead**5.0d0
27156 !c! dF/dom1
27157        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27158 !c! dF/dom2
27159        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27160 !c--------------------------------------------------------------------
27161 !c--------------------------------------------------------------------
27162 !c Polarization energy
27163 !c Epol
27164        MomoFac2 = (1.0d0 - chi2 * sqom1)
27165        RR2  = R2 * R2 / MomoFac2
27166        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27167        fgb2 = sqrt(RR2  + a12sq * ee2)
27168        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27169        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27170                / (fgb2 ** 5.0d0)
27171        dFGBdR2 = ( (R2 / MomoFac2)  &
27172                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27173                / (2.0d0 * fgb2)
27174        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27175                 * (2.0d0 - 0.5d0 * ee2) ) &
27176                 / (2.0d0 * fgb2)
27177        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27178 !c!       dPOLdR2 = 0.0d0
27179        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27180 !c!       dPOLdOM1 = 0.0d0
27181        dPOLdOM2 = 0.0d0
27182 !c!-------------------------------------------------------------------
27183 !c! Elj
27184        pom = (pis / Rhead)**6.0d0
27185        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27186 !c! derivative of Elj is Glj
27187        dGLJdR = 4.0d0 * eps_head &
27188            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27189            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27190 !c!-------------------------------------------------------------------
27191
27192 !c! Return the results
27193 !c! (see comments in Eqq)
27194        DO k = 1, 3
27195         erhead(k) = Rhead_distance(k)/Rhead
27196         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27197        END DO
27198        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27199        erdxj = scalar( erhead(1), dC_norm(1,j) )
27200        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27201        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27202        facd1 = d1 * vbld_inv(i+nres)
27203        facd2 = d2 * vbld_inv(j)
27204        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27205        DO k = 1, 3
27206         condor = (erhead_tail(k,2) &
27207        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27208
27209         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27210         gradpepcatx(k,i) = gradpepcatx(k,i) &
27211                   - dGCLdR * pom &
27212                   - dPOLdR2 * (erhead_tail(k,2) &
27213        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27214                   - dGLJdR * pom
27215
27216         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27217 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27218 !                  + dGCLdR * pom &
27219 !                  + dPOLdR2 * condor &
27220 !                  + dGLJdR * pom
27221
27222
27223         gradpepcat(k,i) = gradpepcat(k,i) &
27224                   - dGCLdR * erhead(k) &
27225                   - dPOLdR2 * erhead_tail(k,2) &
27226                   - dGLJdR * erhead(k)
27227
27228         gradpepcat(k,j) = gradpepcat(k,j) &
27229                   + dGCLdR * erhead(k) &
27230                   + dPOLdR2 * erhead_tail(k,2) &
27231                   + dGLJdR * erhead(k)
27232
27233        END DO
27234        RETURN
27235       END SUBROUTINE edq_cat
27236
27237       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27238       use comm_momo
27239       use calc_data
27240
27241       double precision  facd3, adler,ecl,elj,epol
27242        alphapol2 = alphapolcat(itypj,itypi)
27243        w1        = wqdipcat(1,itypi,itypj)
27244        w2        = wqdipcat(2,itypi,itypj)
27245        pis       = sig0headcat(itypi,itypj)
27246        eps_head  = epsheadcat(itypi,itypj)
27247 !c!-------------------------------------------------------------------
27248 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27249        R2 = 0.0d0
27250        DO k = 1, 3
27251 !c! Calculate head-to-tail distances
27252         R2=R2+(chead(k,2)-ctail(k,1))**2
27253        END DO
27254 !c! Pitagoras
27255        R2 = dsqrt(R2)
27256
27257 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27258 !c!     &        +dhead(1,1,itypi,itypj))**2))
27259 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27260 !c!     &        +dhead(2,1,itypi,itypj))**2))
27261
27262
27263 !c!-------------------------------------------------------------------
27264 !c! ecl
27265        sparrow  = w1 * Qj * om1
27266        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27267 !       print *,"CO2", itypi,itypj
27268 !       print *,"CO?!.", w1,w2,Qj,om1
27269        ECL = sparrow / Rhead**2.0d0 &
27270            - hawk    / Rhead**4.0d0
27271 !c!-------------------------------------------------------------------
27272 !c! derivative of ecl is Gcl
27273 !c! dF/dr part
27274        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27275                  + 4.0d0 * hawk    / Rhead**5.0d0
27276 !c! dF/dom1
27277        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27278 !c! dF/dom2
27279        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27280 !c--------------------------------------------------------------------
27281 !c--------------------------------------------------------------------
27282 !c Polarization energy
27283 !c Epol
27284        MomoFac2 = (1.0d0 - chi2 * sqom1)
27285        RR2  = R2 * R2 / MomoFac2
27286        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27287        fgb2 = sqrt(RR2  + a12sq * ee2)
27288        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27289        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27290                / (fgb2 ** 5.0d0)
27291        dFGBdR2 = ( (R2 / MomoFac2)  &
27292                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27293                / (2.0d0 * fgb2)
27294        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27295                 * (2.0d0 - 0.5d0 * ee2) ) &
27296                 / (2.0d0 * fgb2)
27297        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27298 !c!       dPOLdR2 = 0.0d0
27299        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27300 !c!       dPOLdOM1 = 0.0d0
27301        dPOLdOM2 = 0.0d0
27302 !c!-------------------------------------------------------------------
27303 !c! Elj
27304        pom = (pis / Rhead)**6.0d0
27305        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27306 !c! derivative of Elj is Glj
27307        dGLJdR = 4.0d0 * eps_head &
27308            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27309            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27310 !c!-------------------------------------------------------------------
27311
27312 !c! Return the results
27313 !c! (see comments in Eqq)
27314        DO k = 1, 3
27315         erhead(k) = Rhead_distance(k)/Rhead
27316         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27317        END DO
27318        erdxi = scalar( erhead(1), dC_norm(1,i) )
27319        erdxj = scalar( erhead(1), dC_norm(1,j) )
27320        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27321        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27322        facd1 = d1 * vbld_inv(i+1)/2.0
27323        facd2 = d2 * vbld_inv(j)
27324        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27325        DO k = 1, 3
27326         condor = (erhead_tail(k,2) &
27327        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27328
27329         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27330 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27331 !                  - dGCLdR * pom &
27332 !                  - dPOLdR2 * (erhead_tail(k,2) &
27333 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27334 !                  - dGLJdR * pom
27335
27336         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27337 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27338 !                  + dGCLdR * pom &
27339 !                  + dPOLdR2 * condor &
27340 !                  + dGLJdR * pom
27341
27342
27343         gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27344                   - dGCLdR * erhead(k) &
27345                   - dPOLdR2 * erhead_tail(k,2) &
27346                   - dGLJdR * erhead(k))
27347         gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27348                   - dGCLdR * erhead(k) &
27349                   - dPOLdR2 * erhead_tail(k,2) &
27350                   - dGLJdR * erhead(k))
27351
27352
27353         gradpepcat(k,j) = gradpepcat(k,j) &
27354                   + dGCLdR * erhead(k) &
27355                   + dPOLdR2 * erhead_tail(k,2) &
27356                   + dGLJdR * erhead(k)
27357
27358        END DO
27359        RETURN
27360       END SUBROUTINE edq_cat_pep
27361
27362       SUBROUTINE edd(ECL)
27363 !       IMPLICIT NONE
27364        use comm_momo
27365       use calc_data
27366
27367        double precision ecl
27368 !c!       csig = sigiso(itypi,itypj)
27369        w1 = wqdip(1,itypi,itypj)
27370        w2 = wqdip(2,itypi,itypj)
27371 !c!-------------------------------------------------------------------
27372 !c! ECL
27373        fac = (om12 - 3.0d0 * om1 * om2)
27374        c1 = (w1 / (Rhead**3.0d0)) * fac
27375        c2 = (w2 / Rhead ** 6.0d0) &
27376           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27377        ECL = c1 - c2
27378 !c!       write (*,*) "w1 = ", w1
27379 !c!       write (*,*) "w2 = ", w2
27380 !c!       write (*,*) "om1 = ", om1
27381 !c!       write (*,*) "om2 = ", om2
27382 !c!       write (*,*) "om12 = ", om12
27383 !c!       write (*,*) "fac = ", fac
27384 !c!       write (*,*) "c1 = ", c1
27385 !c!       write (*,*) "c2 = ", c2
27386 !c!       write (*,*) "Ecl = ", Ecl
27387 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27388 !c!       write (*,*) "c2_2 = ",
27389 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27390 !c!-------------------------------------------------------------------
27391 !c! dervative of ECL is GCL...
27392 !c! dECL/dr
27393        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27394        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27395           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27396        dGCLdR = c1 - c2
27397 !c! dECL/dom1
27398        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27399        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27400           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27401        dGCLdOM1 = c1 - c2
27402 !c! dECL/dom2
27403        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27404        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27405           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27406        dGCLdOM2 = c1 - c2
27407 !c! dECL/dom12
27408        c1 = w1 / (Rhead ** 3.0d0)
27409        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27410        dGCLdOM12 = c1 - c2
27411 !c!-------------------------------------------------------------------
27412 !c! Return the results
27413 !c! (see comments in Eqq)
27414        DO k= 1, 3
27415         erhead(k) = Rhead_distance(k)/Rhead
27416        END DO
27417        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27418        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27419        facd1 = d1 * vbld_inv(i+nres)
27420        facd2 = d2 * vbld_inv(j+nres)
27421        DO k = 1, 3
27422
27423         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27424         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27425         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27426         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27427
27428         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27429         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27430        END DO
27431        RETURN
27432       END SUBROUTINE edd
27433       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27434 !       IMPLICIT NONE
27435        use comm_momo
27436       use calc_data
27437
27438        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27439        eps_out=80.0d0
27440        itypi = itype(i,1)
27441        itypj = itype(j,1)
27442 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27443 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27444 !c!       t_bath = 300
27445 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27446        Rb=0.001986d0
27447        BetaT = 1.0d0 / (298.0d0 * Rb)
27448 !c! Gay-berne var's
27449        sig0ij = sigma( itypi,itypj )
27450        chi1   = chi( itypi, itypj )
27451        chi2   = chi( itypj, itypi )
27452        chi12  = chi1 * chi2
27453        chip1  = chipp( itypi, itypj )
27454        chip2  = chipp( itypj, itypi )
27455        chip12 = chip1 * chip2
27456 !       chi1=0.0
27457 !       chi2=0.0
27458 !       chi12=0.0
27459 !       chip1=0.0
27460 !       chip2=0.0
27461 !       chip12=0.0
27462 !c! not used by momo potential, but needed by sc_angular which is shared
27463 !c! by all energy_potential subroutines
27464        alf1   = 0.0d0
27465        alf2   = 0.0d0
27466        alf12  = 0.0d0
27467 !c! location, location, location
27468 !       xj  = c( 1, nres+j ) - xi
27469 !       yj  = c( 2, nres+j ) - yi
27470 !       zj  = c( 3, nres+j ) - zi
27471        dxj = dc_norm( 1, nres+j )
27472        dyj = dc_norm( 2, nres+j )
27473        dzj = dc_norm( 3, nres+j )
27474 !c! distance from center of chain(?) to polar/charged head
27475 !c!       write (*,*) "istate = ", 1
27476 !c!       write (*,*) "ii = ", 1
27477 !c!       write (*,*) "jj = ", 1
27478        d1 = dhead(1, 1, itypi, itypj)
27479        d2 = dhead(2, 1, itypi, itypj)
27480 !c! ai*aj from Fgb
27481        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27482 !c!       a12sq = a12sq * a12sq
27483 !c! charge of amino acid itypi is...
27484        Qi  = icharge(itypi)
27485        Qj  = icharge(itypj)
27486        Qij = Qi * Qj
27487 !c! chis1,2,12
27488        chis1 = chis(itypi,itypj)
27489        chis2 = chis(itypj,itypi)
27490        chis12 = chis1 * chis2
27491        sig1 = sigmap1(itypi,itypj)
27492        sig2 = sigmap2(itypi,itypj)
27493 !c!       write (*,*) "sig1 = ", sig1
27494 !c!       write (*,*) "sig2 = ", sig2
27495 !c! alpha factors from Fcav/Gcav
27496        b1cav = alphasur(1,itypi,itypj)
27497 !       b1cav=0.0
27498        b2cav = alphasur(2,itypi,itypj)
27499        b3cav = alphasur(3,itypi,itypj)
27500        b4cav = alphasur(4,itypi,itypj)
27501        wqd = wquad(itypi, itypj)
27502 !c! used by Fgb
27503        eps_in = epsintab(itypi,itypj)
27504        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27505 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27506 !c!-------------------------------------------------------------------
27507 !c! tail location and distance calculations
27508        Rtail = 0.0d0
27509        DO k = 1, 3
27510         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27511         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27512        END DO
27513 !c! tail distances will be themselves usefull elswhere
27514 !c1 (in Gcav, for example)
27515        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27516        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27517        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27518        Rtail = dsqrt(  &
27519           (Rtail_distance(1)*Rtail_distance(1))  &
27520         + (Rtail_distance(2)*Rtail_distance(2))  &
27521         + (Rtail_distance(3)*Rtail_distance(3)))
27522 !c!-------------------------------------------------------------------
27523 !c! Calculate location and distance between polar heads
27524 !c! distance between heads
27525 !c! for each one of our three dimensional space...
27526        d1 = dhead(1, 1, itypi, itypj)
27527        d2 = dhead(2, 1, itypi, itypj)
27528
27529        DO k = 1,3
27530 !c! location of polar head is computed by taking hydrophobic centre
27531 !c! and moving by a d1 * dc_norm vector
27532 !c! see unres publications for very informative images
27533         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27534         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27535 !c! distance
27536 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27537 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27538         Rhead_distance(k) = chead(k,2) - chead(k,1)
27539        END DO
27540 !c! pitagoras (root of sum of squares)
27541        Rhead = dsqrt(   &
27542           (Rhead_distance(1)*Rhead_distance(1)) &
27543         + (Rhead_distance(2)*Rhead_distance(2)) &
27544         + (Rhead_distance(3)*Rhead_distance(3)))
27545 !c!-------------------------------------------------------------------
27546 !c! zero everything that should be zero'ed
27547        Egb = 0.0d0
27548        ECL = 0.0d0
27549        Elj = 0.0d0
27550        Equad = 0.0d0
27551        Epol = 0.0d0
27552        eheadtail = 0.0d0
27553        dGCLdOM1 = 0.0d0
27554        dGCLdOM2 = 0.0d0
27555        dGCLdOM12 = 0.0d0
27556        dPOLdOM1 = 0.0d0
27557        dPOLdOM2 = 0.0d0
27558        RETURN
27559       END SUBROUTINE elgrad_init
27560
27561
27562       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27563       use comm_momo
27564       use calc_data
27565        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27566        eps_out=80.0d0
27567        itypi = itype(i,1)
27568        itypj = itype(j,5)
27569 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27570 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27571 !c!       t_bath = 300
27572 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27573        Rb=0.001986d0
27574        BetaT = 1.0d0 / (298.0d0 * Rb)
27575 !c! Gay-berne var's
27576        sig0ij = sigmacat( itypi,itypj )
27577        chi1   = chi1cat( itypi, itypj )
27578        chi2   = 0.0d0
27579        chi12  = 0.0d0
27580        chip1  = chipp1cat( itypi, itypj )
27581        chip2  = 0.0d0
27582        chip12 = 0.0d0
27583 !c! not used by momo potential, but needed by sc_angular which is shared
27584 !c! by all energy_potential subroutines
27585        alf1   = 0.0d0
27586        alf2   = 0.0d0
27587        alf12  = 0.0d0
27588        dxj = dc_norm( 1, nres+j )
27589        dyj = dc_norm( 2, nres+j )
27590        dzj = dc_norm( 3, nres+j )
27591 !c! distance from center of chain(?) to polar/charged head
27592        d1 = dheadcat(1, 1, itypi, itypj)
27593        d2 = dheadcat(2, 1, itypi, itypj)
27594 !c! ai*aj from Fgb
27595        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27596 !c!       a12sq = a12sq * a12sq
27597 !c! charge of amino acid itypi is...
27598        Qi  = icharge(itypi)
27599        Qj  = ichargecat(itypj)
27600        Qij = Qi * Qj
27601 !c! chis1,2,12
27602        chis1 = chis1cat(itypi,itypj)
27603        chis2 = 0.0d0
27604        chis12 = 0.0d0
27605        sig1 = sigmap1cat(itypi,itypj)
27606        sig2 = sigmap2cat(itypi,itypj)
27607 !c! alpha factors from Fcav/Gcav
27608        b1cav = alphasurcat(1,itypi,itypj)
27609        b2cav = alphasurcat(2,itypi,itypj)
27610        b3cav = alphasurcat(3,itypi,itypj)
27611        b4cav = alphasurcat(4,itypi,itypj)
27612        wqd = wquadcat(itypi, itypj)
27613 !c! used by Fgb
27614        eps_in = epsintabcat(itypi,itypj)
27615        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27616 !c!-------------------------------------------------------------------
27617 !c! tail location and distance calculations
27618        Rtail = 0.0d0
27619        DO k = 1, 3
27620         ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27621         ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27622        END DO
27623 !c! tail distances will be themselves usefull elswhere
27624 !c1 (in Gcav, for example)
27625        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27626        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27627        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27628        Rtail = dsqrt(  &
27629           (Rtail_distance(1)*Rtail_distance(1))  &
27630         + (Rtail_distance(2)*Rtail_distance(2))  &
27631         + (Rtail_distance(3)*Rtail_distance(3)))
27632 !c!-------------------------------------------------------------------
27633 !c! Calculate location and distance between polar heads
27634 !c! distance between heads
27635 !c! for each one of our three dimensional space...
27636        d1 = dheadcat(1, 1, itypi, itypj)
27637        d2 = dheadcat(2, 1, itypi, itypj)
27638
27639        DO k = 1,3
27640 !c! location of polar head is computed by taking hydrophobic centre
27641 !c! and moving by a d1 * dc_norm vector
27642 !c! see unres publications for very informative images
27643         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27644         chead(k,2) = c(k, j)
27645 !c! distance
27646 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27647 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27648         Rhead_distance(k) = chead(k,2) - chead(k,1)
27649        END DO
27650 !c! pitagoras (root of sum of squares)
27651        Rhead = dsqrt(   &
27652           (Rhead_distance(1)*Rhead_distance(1)) &
27653         + (Rhead_distance(2)*Rhead_distance(2)) &
27654         + (Rhead_distance(3)*Rhead_distance(3)))
27655 !c!-------------------------------------------------------------------
27656 !c! zero everything that should be zero'ed
27657        Egb = 0.0d0
27658        ECL = 0.0d0
27659        Elj = 0.0d0
27660        Equad = 0.0d0
27661        Epol = 0.0d0
27662        eheadtail = 0.0d0
27663        dGCLdOM1 = 0.0d0
27664        dGCLdOM2 = 0.0d0
27665        dGCLdOM12 = 0.0d0
27666        dPOLdOM1 = 0.0d0
27667        dPOLdOM2 = 0.0d0
27668        RETURN
27669       END SUBROUTINE elgrad_init_cat
27670
27671       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27672       use comm_momo
27673       use calc_data
27674        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27675        eps_out=80.0d0
27676        itypi = 10
27677        itypj = itype(j,5)
27678 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27679 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27680 !c!       t_bath = 300
27681 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27682        Rb=0.001986d0
27683        BetaT = 1.0d0 / (298.0d0 * Rb)
27684 !c! Gay-berne var's
27685        sig0ij = sigmacat( itypi,itypj )
27686        chi1   = chi1cat( itypi, itypj )
27687        chi2   = 0.0d0
27688        chi12  = 0.0d0
27689        chip1  = chipp1cat( itypi, itypj )
27690        chip2  = 0.0d0
27691        chip12 = 0.0d0
27692 !c! not used by momo potential, but needed by sc_angular which is shared
27693 !c! by all energy_potential subroutines
27694        alf1   = 0.0d0
27695        alf2   = 0.0d0
27696        alf12  = 0.0d0
27697        dxj = 0.0d0 !dc_norm( 1, nres+j )
27698        dyj = 0.0d0 !dc_norm( 2, nres+j )
27699        dzj = 0.0d0 !dc_norm( 3, nres+j )
27700 !c! distance from center of chain(?) to polar/charged head
27701        d1 = dheadcat(1, 1, itypi, itypj)
27702        d2 = dheadcat(2, 1, itypi, itypj)
27703 !c! ai*aj from Fgb
27704        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27705 !c!       a12sq = a12sq * a12sq
27706 !c! charge of amino acid itypi is...
27707        Qi  = 0
27708        Qj  = ichargecat(itypj)
27709 !       Qij = Qi * Qj
27710 !c! chis1,2,12
27711        chis1 = chis1cat(itypi,itypj)
27712        chis2 = 0.0d0
27713        chis12 = 0.0d0
27714        sig1 = sigmap1cat(itypi,itypj)
27715        sig2 = sigmap2cat(itypi,itypj)
27716 !c! alpha factors from Fcav/Gcav
27717        b1cav = alphasurcat(1,itypi,itypj)
27718        b2cav = alphasurcat(2,itypi,itypj)
27719        b3cav = alphasurcat(3,itypi,itypj)
27720        b4cav = alphasurcat(4,itypi,itypj)
27721        wqd = wquadcat(itypi, itypj)
27722 !c! used by Fgb
27723        eps_in = epsintabcat(itypi,itypj)
27724        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27725 !c!-------------------------------------------------------------------
27726 !c! tail location and distance calculations
27727        Rtail = 0.0d0
27728        DO k = 1, 3
27729         ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
27730         ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27731        END DO
27732 !c! tail distances will be themselves usefull elswhere
27733 !c1 (in Gcav, for example)
27734        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27735        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27736        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27737        Rtail = dsqrt(  &
27738           (Rtail_distance(1)*Rtail_distance(1))  &
27739         + (Rtail_distance(2)*Rtail_distance(2))  &
27740         + (Rtail_distance(3)*Rtail_distance(3)))
27741 !c!-------------------------------------------------------------------
27742 !c! Calculate location and distance between polar heads
27743 !c! distance between heads
27744 !c! for each one of our three dimensional space...
27745        d1 = dheadcat(1, 1, itypi, itypj)
27746        d2 = dheadcat(2, 1, itypi, itypj)
27747
27748        DO k = 1,3
27749 !c! location of polar head is computed by taking hydrophobic centre
27750 !c! and moving by a d1 * dc_norm vector
27751 !c! see unres publications for very informative images
27752         chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
27753         chead(k,2) = c(k, j)
27754 !c! distance
27755 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27756 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27757         Rhead_distance(k) = chead(k,2) - chead(k,1)
27758        END DO
27759 !c! pitagoras (root of sum of squares)
27760        Rhead = dsqrt(   &
27761           (Rhead_distance(1)*Rhead_distance(1)) &
27762         + (Rhead_distance(2)*Rhead_distance(2)) &
27763         + (Rhead_distance(3)*Rhead_distance(3)))
27764 !c!-------------------------------------------------------------------
27765 !c! zero everything that should be zero'ed
27766        Egb = 0.0d0
27767        ECL = 0.0d0
27768        Elj = 0.0d0
27769        Equad = 0.0d0
27770        Epol = 0.0d0
27771        eheadtail = 0.0d0
27772        dGCLdOM1 = 0.0d0
27773        dGCLdOM2 = 0.0d0
27774        dGCLdOM12 = 0.0d0
27775        dPOLdOM1 = 0.0d0
27776        dPOLdOM2 = 0.0d0
27777        RETURN
27778       END SUBROUTINE elgrad_init_cat_pep
27779
27780       double precision function tschebyshev(m,n,x,y)
27781       implicit none
27782       integer i,m,n
27783       double precision x(n),y,yy(0:maxvar),aux
27784 !c Tschebyshev polynomial. Note that the first term is omitted
27785 !c m=0: the constant term is included
27786 !c m=1: the constant term is not included
27787       yy(0)=1.0d0
27788       yy(1)=y
27789       do i=2,n
27790         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27791       enddo
27792       aux=0.0d0
27793       do i=m,n
27794         aux=aux+x(i)*yy(i)
27795       enddo
27796       tschebyshev=aux
27797       return
27798       end function tschebyshev
27799 !C--------------------------------------------------------------------------
27800       double precision function gradtschebyshev(m,n,x,y)
27801       implicit none
27802       integer i,m,n
27803       double precision x(n+1),y,yy(0:maxvar),aux
27804 !c Tschebyshev polynomial. Note that the first term is omitted
27805 !c m=0: the constant term is included
27806 !c m=1: the constant term is not included
27807       yy(0)=1.0d0
27808       yy(1)=2.0d0*y
27809       do i=2,n
27810         yy(i)=2*y*yy(i-1)-yy(i-2)
27811       enddo
27812       aux=0.0d0
27813       do i=m,n
27814         aux=aux+x(i+1)*yy(i)*(i+1)
27815 !C        print *, x(i+1),yy(i),i
27816       enddo
27817       gradtschebyshev=aux
27818       return
27819       end function gradtschebyshev
27820
27821       subroutine make_SCSC_inter_list
27822       include 'mpif.h'
27823       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27824       real*8 :: dist_init, dist_temp,r_buff_list
27825       integer:: contlisti(200*nres),contlistj(200*nres)
27826 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
27827       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
27828       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
27829 !            print *,"START make_SC"
27830           r_buff_list=5.0
27831             ilist_sc=0
27832             do i=iatsc_s,iatsc_e
27833              itypi=iabs(itype(i,1))
27834              if (itypi.eq.ntyp1) cycle
27835              xi=c(1,nres+i)
27836              yi=c(2,nres+i)
27837              zi=c(3,nres+i)
27838              xi=dmod(xi,boxxsize)
27839              if (xi.lt.0) xi=xi+boxxsize
27840              yi=dmod(yi,boxysize)
27841              if (yi.lt.0) yi=yi+boxysize
27842              zi=dmod(zi,boxzsize)
27843              if (zi.lt.0) zi=zi+boxzsize
27844              do iint=1,nint_gr(i)
27845               do j=istart(i,iint),iend(i,iint)
27846                itypj=iabs(itype(j,1))
27847                if (itypj.eq.ntyp1) cycle
27848                xj=c(1,nres+j)
27849                yj=c(2,nres+j)
27850                zj=c(3,nres+j)
27851                xj=dmod(xj,boxxsize)
27852                if (xj.lt.0) xj=xj+boxxsize
27853                yj=dmod(yj,boxysize)
27854                if (yj.lt.0) yj=yj+boxysize
27855                zj=dmod(zj,boxzsize)
27856                if (zj.lt.0) zj=zj+boxzsize
27857                dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27858                xj_safe=xj
27859                yj_safe=yj
27860                zj_safe=zj
27861                subchap=0
27862                do xshift=-1,1
27863                do yshift=-1,1
27864                do zshift=-1,1
27865                xj=xj_safe+xshift*boxxsize
27866                yj=yj_safe+yshift*boxysize
27867                zj=zj_safe+zshift*boxzsize
27868                dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27869                if(dist_temp.lt.dist_init) then
27870                 dist_init=dist_temp
27871                 xj_temp=xj
27872                 yj_temp=yj
27873                 zj_temp=zj
27874                 subchap=1
27875                endif
27876                enddo
27877                enddo
27878                enddo
27879                if (subchap.eq.1) then
27880                xj=xj_temp-xi
27881                yj=yj_temp-yi
27882                zj=zj_temp-zi
27883                else
27884                xj=xj_safe-xi
27885                yj=yj_safe-yi
27886                zj=zj_safe-zi
27887                endif
27888 ! r_buff_list is a read value for a buffer
27889                if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27890 ! Here the list is created
27891                  ilist_sc=ilist_sc+1
27892 ! this can be substituted by cantor and anti-cantor
27893                  contlisti(ilist_sc)=i
27894                  contlistj(ilist_sc)=j
27895
27896                endif
27897              enddo
27898              enddo
27899              enddo
27900 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27901 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27902 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
27903 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
27904 #ifdef DEBUG
27905       write (iout,*) "before MPIREDUCE",ilist_sc
27906       do i=1,ilist_sc
27907       write (iout,*) i,contlisti(i),contlistj(i)
27908       enddo
27909 #endif
27910       if (nfgtasks.gt.1)then
27911
27912         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27913           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27914 !        write(iout,*) "before bcast",g_ilist_sc
27915         call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
27916                         i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
27917         displ(0)=0
27918         do i=1,nfgtasks-1,1
27919           displ(i)=i_ilist_sc(i-1)+displ(i-1)
27920         enddo
27921 !        write(iout,*) "before gather",displ(0),displ(1)
27922         call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
27923                          newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
27924                          king,FG_COMM,IERR)
27925         call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
27926                          newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
27927                          king,FG_COMM,IERR)
27928         call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
27929 !        write(iout,*) "before bcast",g_ilist_sc
27930 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27931         call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27932         call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27933
27934 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27935
27936         else
27937         g_ilist_sc=ilist_sc
27938
27939         do i=1,ilist_sc
27940         newcontlisti(i)=contlisti(i)
27941         newcontlistj(i)=contlistj(i)
27942         enddo
27943         endif
27944
27945 #ifdef DEBUG
27946       write (iout,*) "after MPIREDUCE",g_ilist_sc
27947       do i=1,g_ilist_sc
27948       write (iout,*) i,newcontlisti(i),newcontlistj(i)
27949       enddo
27950 #endif
27951         call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
27952       return
27953       end subroutine make_SCSC_inter_list
27954 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
27955
27956       subroutine make_SCp_inter_list
27957       use MD_data,  only: itime_mat
27958
27959       include 'mpif.h'
27960       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27961       real*8 :: dist_init, dist_temp,r_buff_list
27962       integer:: contlistscpi(200*nres),contlistscpj(200*nres)
27963 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
27964       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
27965       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
27966 !            print *,"START make_SC"
27967       r_buff_list=5.0
27968             ilist_scp=0
27969       do i=iatscp_s,iatscp_e
27970         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27971         xi=0.5D0*(c(1,i)+c(1,i+1))
27972         yi=0.5D0*(c(2,i)+c(2,i+1))
27973         zi=0.5D0*(c(3,i)+c(3,i+1))
27974           xi=mod(xi,boxxsize)
27975           if (xi.lt.0) xi=xi+boxxsize
27976           yi=mod(yi,boxysize)
27977           if (yi.lt.0) yi=yi+boxysize
27978           zi=mod(zi,boxzsize)
27979           if (zi.lt.0) zi=zi+boxzsize
27980
27981         do iint=1,nscp_gr(i)
27982
27983         do j=iscpstart(i,iint),iscpend(i,iint)
27984           itypj=iabs(itype(j,1))
27985           if (itypj.eq.ntyp1) cycle
27986 ! Uncomment following three lines for SC-p interactions
27987 !         xj=c(1,nres+j)-xi
27988 !         yj=c(2,nres+j)-yi
27989 !         zj=c(3,nres+j)-zi
27990 ! Uncomment following three lines for Ca-p interactions
27991 !          xj=c(1,j)-xi
27992 !          yj=c(2,j)-yi
27993 !          zj=c(3,j)-zi
27994           xj=c(1,j)
27995           yj=c(2,j)
27996           zj=c(3,j)
27997           xj=mod(xj,boxxsize)
27998           if (xj.lt.0) xj=xj+boxxsize
27999           yj=mod(yj,boxysize)
28000           if (yj.lt.0) yj=yj+boxysize
28001           zj=mod(zj,boxzsize)
28002           if (zj.lt.0) zj=zj+boxzsize
28003       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28004       xj_safe=xj
28005       yj_safe=yj
28006       zj_safe=zj
28007       subchap=0
28008       do xshift=-1,1
28009       do yshift=-1,1
28010       do zshift=-1,1
28011           xj=xj_safe+xshift*boxxsize
28012           yj=yj_safe+yshift*boxysize
28013           zj=zj_safe+zshift*boxzsize
28014           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28015           if(dist_temp.lt.dist_init) then
28016             dist_init=dist_temp
28017             xj_temp=xj
28018             yj_temp=yj
28019             zj_temp=zj
28020             subchap=1
28021           endif
28022        enddo
28023        enddo
28024        enddo
28025        if (subchap.eq.1) then
28026           xj=xj_temp-xi
28027           yj=yj_temp-yi
28028           zj=zj_temp-zi
28029        else
28030           xj=xj_safe-xi
28031           yj=yj_safe-yi
28032           zj=zj_safe-zi
28033        endif
28034 #ifdef DEBUG
28035                 ! r_buff_list is a read value for a buffer
28036                if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
28037 ! Here the list is created
28038                  ilist_scp_first=ilist_scp_first+1
28039 ! this can be substituted by cantor and anti-cantor
28040                  contlistscpi_f(ilist_scp_first)=i
28041                  contlistscpj_f(ilist_scp_first)=j
28042               endif
28043 #endif
28044 ! r_buff_list is a read value for a buffer
28045                if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28046 ! Here the list is created
28047                  ilist_scp=ilist_scp+1
28048 ! this can be substituted by cantor and anti-cantor
28049                  contlistscpi(ilist_scp)=i
28050                  contlistscpj(ilist_scp)=j
28051               endif
28052              enddo
28053              enddo
28054              enddo
28055 #ifdef DEBUG
28056       write (iout,*) "before MPIREDUCE",ilist_scp
28057       do i=1,ilist_scp
28058       write (iout,*) i,contlistscpi(i),contlistscpj(i)
28059       enddo
28060 #endif
28061       if (nfgtasks.gt.1)then
28062
28063         call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
28064           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28065 !        write(iout,*) "before bcast",g_ilist_sc
28066         call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
28067                         i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
28068         displ(0)=0
28069         do i=1,nfgtasks-1,1
28070           displ(i)=i_ilist_scp(i-1)+displ(i-1)
28071         enddo
28072 !        write(iout,*) "before gather",displ(0),displ(1)
28073         call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
28074                          newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
28075                          king,FG_COMM,IERR)
28076         call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
28077                          newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
28078                          king,FG_COMM,IERR)
28079         call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
28080 !        write(iout,*) "before bcast",g_ilist_sc
28081 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28082         call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28083         call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28084
28085 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28086
28087         else
28088         g_ilist_scp=ilist_scp
28089
28090         do i=1,ilist_scp
28091         newcontlistscpi(i)=contlistscpi(i)
28092         newcontlistscpj(i)=contlistscpj(i)
28093         enddo
28094         endif
28095
28096 #ifdef DEBUG
28097       write (iout,*) "after MPIREDUCE",g_ilist_scp
28098       do i=1,g_ilist_scp
28099       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
28100       enddo
28101
28102 !      if (ifirstrun.eq.0) ifirstrun=1
28103 !      do i=1,ilist_scp_first
28104 !       do j=1,g_ilist_scp
28105 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
28106 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
28107 !        enddo
28108 !       print *,itime_mat,"ERROR matrix needs updating"
28109 !       print *,contlistscpi_f(i),contlistscpj_f(i)
28110 !  126  continue
28111 !      enddo
28112 #endif
28113         call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
28114
28115       return
28116       end subroutine make_SCp_inter_list
28117
28118 !-----------------------------------------------------------------------------
28119 !-----------------------------------------------------------------------------
28120
28121
28122       subroutine make_pp_inter_list
28123       include 'mpif.h'
28124       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28125       real*8 :: xmedj,ymedj,zmedj
28126       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
28127       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
28128       integer:: contlistppi(200*nres),contlistppj(200*nres)
28129 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
28130       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
28131       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
28132 !            print *,"START make_SC"
28133             ilist_pp=0
28134       r_buff_list=5.0
28135       do i=iatel_s,iatel_e
28136         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28137         dxi=dc(1,i)
28138         dyi=dc(2,i)
28139         dzi=dc(3,i)
28140         dx_normi=dc_norm(1,i)
28141         dy_normi=dc_norm(2,i)
28142         dz_normi=dc_norm(3,i)
28143         xmedi=c(1,i)+0.5d0*dxi
28144         ymedi=c(2,i)+0.5d0*dyi
28145         zmedi=c(3,i)+0.5d0*dzi
28146           xmedi=dmod(xmedi,boxxsize)
28147           if (xmedi.lt.0) xmedi=xmedi+boxxsize
28148           ymedi=dmod(ymedi,boxysize)
28149           if (ymedi.lt.0) ymedi=ymedi+boxysize
28150           zmedi=dmod(zmedi,boxzsize)
28151           if (zmedi.lt.0) zmedi=zmedi+boxzsize
28152              do j=ielstart(i),ielend(i)
28153 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28154           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28155
28156 ! 1,j)
28157           dxj=dc(1,j)
28158           dyj=dc(2,j)
28159           dzj=dc(3,j)
28160           dx_normj=dc_norm(1,j)
28161           dy_normj=dc_norm(2,j)
28162           dz_normj=dc_norm(3,j)
28163 !          xj=c(1,j)+0.5D0*dxj-xmedi
28164 !          yj=c(2,j)+0.5D0*dyj-ymedi
28165 !          zj=c(3,j)+0.5D0*dzj-zmedi
28166           xj=c(1,j)+0.5D0*dxj
28167           yj=c(2,j)+0.5D0*dyj
28168           zj=c(3,j)+0.5D0*dzj
28169           xj=mod(xj,boxxsize)
28170           if (xj.lt.0) xj=xj+boxxsize
28171           yj=mod(yj,boxysize)
28172           if (yj.lt.0) yj=yj+boxysize
28173           zj=mod(zj,boxzsize)
28174           if (zj.lt.0) zj=zj+boxzsize
28175
28176       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
28177       xj_safe=xj
28178       yj_safe=yj
28179       zj_safe=zj
28180       do xshift=-1,1
28181       do yshift=-1,1
28182       do zshift=-1,1
28183           xj=xj_safe+xshift*boxxsize
28184           yj=yj_safe+yshift*boxysize
28185           zj=zj_safe+zshift*boxzsize
28186           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
28187           if(dist_temp.lt.dist_init) then
28188             dist_init=dist_temp
28189             xj_temp=xj
28190             yj_temp=yj
28191             zj_temp=zj
28192           endif
28193        enddo
28194        enddo
28195        enddo
28196
28197       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28198 ! Here the list is created
28199                  ilist_pp=ilist_pp+1
28200 ! this can be substituted by cantor and anti-cantor
28201                  contlistppi(ilist_pp)=i
28202                  contlistppj(ilist_pp)=j
28203               endif
28204              enddo
28205              enddo
28206 !             enddo
28207 #ifdef DEBUG
28208       write (iout,*) "before MPIREDUCE",ilist_pp
28209       do i=1,ilist_pp
28210       write (iout,*) i,contlistppi(i),contlistppj(i)
28211       enddo
28212 #endif
28213       if (nfgtasks.gt.1)then
28214
28215         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
28216           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28217 !        write(iout,*) "before bcast",g_ilist_sc
28218         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
28219                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
28220         displ(0)=0
28221         do i=1,nfgtasks-1,1
28222           displ(i)=i_ilist_pp(i-1)+displ(i-1)
28223         enddo
28224 !        write(iout,*) "before gather",displ(0),displ(1)
28225         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
28226                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
28227                          king,FG_COMM,IERR)
28228         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
28229                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
28230                          king,FG_COMM,IERR)
28231         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
28232 !        write(iout,*) "before bcast",g_ilist_sc
28233 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28234         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28235         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28236
28237 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28238
28239         else
28240         g_ilist_pp=ilist_pp
28241
28242         do i=1,ilist_pp
28243         newcontlistppi(i)=contlistppi(i)
28244         newcontlistppj(i)=contlistppj(i)
28245         enddo
28246         endif
28247         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
28248 #ifdef DEBUG
28249       write (iout,*) "after MPIREDUCE",g_ilist_pp
28250       do i=1,g_ilist_pp
28251       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
28252       enddo
28253 #endif
28254       return
28255       end subroutine make_pp_inter_list
28256
28257 !-----------------------------------------------------------------------------
28258       double precision function boxshift(x,boxsize)
28259       implicit none
28260       double precision x,boxsize
28261       double precision xtemp
28262       xtemp=dmod(x,boxsize)
28263       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
28264         boxshift=xtemp-boxsize
28265       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
28266         boxshift=xtemp+boxsize
28267       else
28268         boxshift=xtemp
28269       endif
28270       return
28271       end function boxshift
28272 !-----------------------------------------------------------------------------
28273       subroutine to_box(xi,yi,zi)
28274       implicit none
28275 !      include 'DIMENSIONS'
28276 !      include 'COMMON.CHAIN'
28277       double precision xi,yi,zi
28278       xi=dmod(xi,boxxsize)
28279       if (xi.lt.0.0d0) xi=xi+boxxsize
28280       yi=dmod(yi,boxysize)
28281       if (yi.lt.0.0d0) yi=yi+boxysize
28282       zi=dmod(zi,boxzsize)
28283       if (zi.lt.0.0d0) zi=zi+boxzsize
28284       return
28285       end subroutine to_box
28286 !--------------------------------------------------------------------------
28287       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
28288       implicit none
28289 !      include 'DIMENSIONS'
28290 !      include 'COMMON.IOUNITS'
28291 !      include 'COMMON.CHAIN'
28292       double precision xi,yi,zi,sslipi,ssgradlipi
28293       double precision fracinbuf
28294 !      double precision sscalelip,sscagradlip
28295 #ifdef DEBUG
28296       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
28297       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
28298       write (iout,*) "xi yi zi",xi,yi,zi
28299 #endif
28300       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
28301 ! the energy transfer exist
28302         if (zi.lt.buflipbot) then
28303 ! what fraction I am in
28304           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
28305 ! lipbufthick is thickenes of lipid buffore
28306           sslipi=sscalelip(fracinbuf)
28307           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
28308         elseif (zi.gt.bufliptop) then
28309           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
28310           sslipi=sscalelip(fracinbuf)
28311           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
28312         else
28313           sslipi=1.0d0
28314           ssgradlipi=0.0
28315         endif
28316       else
28317         sslipi=0.0d0
28318         ssgradlipi=0.0
28319       endif
28320 #ifdef DEBUG
28321       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
28322 #endif
28323       return
28324       end subroutine lipid_layer
28325
28326 !--------------------------------------------------------------------------
28327 !--------------------------------------------------------------------------
28328       end module energy