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
1457       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1458       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1459
1460 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1461       evdw=0.0D0
1462 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1463 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1464 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1465 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1466
1467       do i=iatsc_s,iatsc_e
1468         itypi=iabs(itype(i,1))
1469         if (itypi.eq.ntyp1) cycle
1470         itypi1=iabs(itype(i+1,1))
1471         xi=c(1,nres+i)
1472         yi=c(2,nres+i)
1473         zi=c(3,nres+i)
1474 ! Change 12/1/95
1475         num_conti=0
1476 !
1477 ! Calculate SC interaction energy.
1478 !
1479         do iint=1,nint_gr(i)
1480 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1481 !d   &                  'iend=',iend(i,iint)
1482           do j=istart(i,iint),iend(i,iint)
1483             itypj=iabs(itype(j,1))
1484             if (itypj.eq.ntyp1) cycle
1485             xj=c(1,nres+j)-xi
1486             yj=c(2,nres+j)-yi
1487             zj=c(3,nres+j)-zi
1488 ! Change 12/1/95 to calculate four-body interactions
1489             rij=xj*xj+yj*yj+zj*zj
1490             rrij=1.0D0/rij
1491 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1492             eps0ij=eps(itypi,itypj)
1493             fac=rrij**expon2
1494             e1=fac*fac*aa_aq(itypi,itypj)
1495             e2=fac*bb_aq(itypi,itypj)
1496             evdwij=e1+e2
1497 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1498 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1499 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1500 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1501 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1502 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1503             evdw=evdw+evdwij
1504 !
1505 ! Calculate the components of the gradient in DC and X
1506 !
1507             fac=-rrij*(e1+evdwij)
1508             gg(1)=xj*fac
1509             gg(2)=yj*fac
1510             gg(3)=zj*fac
1511             do k=1,3
1512               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1513               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1514               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1515               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1516             enddo
1517 !grad            do k=i,j-1
1518 !grad              do l=1,3
1519 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1520 !grad              enddo
1521 !grad            enddo
1522 !
1523 ! 12/1/95, revised on 5/20/97
1524 !
1525 ! Calculate the contact function. The ith column of the array JCONT will
1526 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1527 ! greater than I). The arrays FACONT and GACONT will contain the values of
1528 ! the contact function and its derivative.
1529 !
1530 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1531 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1532 ! Uncomment next line, if the correlation interactions are contact function only
1533             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1534               rij=dsqrt(rij)
1535               sigij=sigma(itypi,itypj)
1536               r0ij=rs0(itypi,itypj)
1537 !
1538 ! Check whether the SC's are not too far to make a contact.
1539 !
1540               rcut=1.5d0*r0ij
1541               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1542 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1543 !
1544               if (fcont.gt.0.0D0) then
1545 ! If the SC-SC distance if close to sigma, apply spline.
1546 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1547 !Adam &             fcont1,fprimcont1)
1548 !Adam           fcont1=1.0d0-fcont1
1549 !Adam           if (fcont1.gt.0.0d0) then
1550 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1551 !Adam             fcont=fcont*fcont1
1552 !Adam           endif
1553 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1554 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1555 !ga             do k=1,3
1556 !ga               gg(k)=gg(k)*eps0ij
1557 !ga             enddo
1558 !ga             eps0ij=-evdwij*eps0ij
1559 ! Uncomment for AL's type of SC correlation interactions.
1560 !adam           eps0ij=-evdwij
1561                 num_conti=num_conti+1
1562                 jcont(num_conti,i)=j
1563                 facont(num_conti,i)=fcont*eps0ij
1564                 fprimcont=eps0ij*fprimcont/rij
1565                 fcont=expon*fcont
1566 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1567 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1568 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1569 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1570                 gacont(1,num_conti,i)=-fprimcont*xj
1571                 gacont(2,num_conti,i)=-fprimcont*yj
1572                 gacont(3,num_conti,i)=-fprimcont*zj
1573 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1574 !d              write (iout,'(2i3,3f10.5)')
1575 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1576               endif
1577             endif
1578           enddo      ! j
1579         enddo        ! iint
1580 ! Change 12/1/95
1581         num_cont(i)=num_conti
1582       enddo          ! i
1583       do i=1,nct
1584         do j=1,3
1585           gvdwc(j,i)=expon*gvdwc(j,i)
1586           gvdwx(j,i)=expon*gvdwx(j,i)
1587         enddo
1588       enddo
1589 !******************************************************************************
1590 !
1591 !                              N O T E !!!
1592 !
1593 ! To save time, the factor of EXPON has been extracted from ALL components
1594 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1595 ! use!
1596 !
1597 !******************************************************************************
1598       return
1599       end subroutine elj
1600 !-----------------------------------------------------------------------------
1601       subroutine eljk(evdw)
1602 !
1603 ! This subroutine calculates the interaction energy of nonbonded side chains
1604 ! assuming the LJK potential of interaction.
1605 !
1606 !      implicit real*8 (a-h,o-z)
1607 !      include 'DIMENSIONS'
1608 !      include 'COMMON.GEO'
1609 !      include 'COMMON.VAR'
1610 !      include 'COMMON.LOCAL'
1611 !      include 'COMMON.CHAIN'
1612 !      include 'COMMON.DERIV'
1613 !      include 'COMMON.INTERACT'
1614 !      include 'COMMON.IOUNITS'
1615 !      include 'COMMON.NAMES'
1616       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1617       logical :: scheck
1618 !el local variables
1619       integer :: i,iint,j,itypi,itypi1,k,itypj
1620       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1621       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1622
1623 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1624       evdw=0.0D0
1625       do i=iatsc_s,iatsc_e
1626         itypi=iabs(itype(i,1))
1627         if (itypi.eq.ntyp1) cycle
1628         itypi1=iabs(itype(i+1,1))
1629         xi=c(1,nres+i)
1630         yi=c(2,nres+i)
1631         zi=c(3,nres+i)
1632 !
1633 ! Calculate SC interaction energy.
1634 !
1635         do iint=1,nint_gr(i)
1636           do j=istart(i,iint),iend(i,iint)
1637             itypj=iabs(itype(j,1))
1638             if (itypj.eq.ntyp1) cycle
1639             xj=c(1,nres+j)-xi
1640             yj=c(2,nres+j)-yi
1641             zj=c(3,nres+j)-zi
1642             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1643             fac_augm=rrij**expon
1644             e_augm=augm(itypi,itypj)*fac_augm
1645             r_inv_ij=dsqrt(rrij)
1646             rij=1.0D0/r_inv_ij
1647             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1648             fac=r_shift_inv**expon
1649             e1=fac*fac*aa_aq(itypi,itypj)
1650             e2=fac*bb_aq(itypi,itypj)
1651             evdwij=e_augm+e1+e2
1652 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1653 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1654 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1655 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1656 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1657 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1658 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1659             evdw=evdw+evdwij
1660 !
1661 ! Calculate the components of the gradient in DC and X
1662 !
1663             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1664             gg(1)=xj*fac
1665             gg(2)=yj*fac
1666             gg(3)=zj*fac
1667             do k=1,3
1668               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1669               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1670               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1671               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1672             enddo
1673 !grad            do k=i,j-1
1674 !grad              do l=1,3
1675 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1676 !grad              enddo
1677 !grad            enddo
1678           enddo      ! j
1679         enddo        ! iint
1680       enddo          ! i
1681       do i=1,nct
1682         do j=1,3
1683           gvdwc(j,i)=expon*gvdwc(j,i)
1684           gvdwx(j,i)=expon*gvdwx(j,i)
1685         enddo
1686       enddo
1687       return
1688       end subroutine eljk
1689 !-----------------------------------------------------------------------------
1690       subroutine ebp(evdw)
1691 !
1692 ! This subroutine calculates the interaction energy of nonbonded side chains
1693 ! assuming the Berne-Pechukas potential of interaction.
1694 !
1695       use comm_srutu
1696       use calc_data
1697 !      implicit real*8 (a-h,o-z)
1698 !      include 'DIMENSIONS'
1699 !      include 'COMMON.GEO'
1700 !      include 'COMMON.VAR'
1701 !      include 'COMMON.LOCAL'
1702 !      include 'COMMON.CHAIN'
1703 !      include 'COMMON.DERIV'
1704 !      include 'COMMON.NAMES'
1705 !      include 'COMMON.INTERACT'
1706 !      include 'COMMON.IOUNITS'
1707 !      include 'COMMON.CALC'
1708       use comm_srutu
1709 !el      integer :: icall
1710 !el      common /srutu/ icall
1711 !     double precision rrsave(maxdim)
1712       logical :: lprn
1713 !el local variables
1714       integer :: iint,itypi,itypi1,itypj
1715       real(kind=8) :: rrij,xi,yi,zi
1716       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1717
1718 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1719       evdw=0.0D0
1720 !     if (icall.eq.0) then
1721 !       lprn=.true.
1722 !     else
1723         lprn=.false.
1724 !     endif
1725 !el      ind=0
1726       do i=iatsc_s,iatsc_e
1727         itypi=iabs(itype(i,1))
1728         if (itypi.eq.ntyp1) cycle
1729         itypi1=iabs(itype(i+1,1))
1730         xi=c(1,nres+i)
1731         yi=c(2,nres+i)
1732         zi=c(3,nres+i)
1733         dxi=dc_norm(1,nres+i)
1734         dyi=dc_norm(2,nres+i)
1735         dzi=dc_norm(3,nres+i)
1736 !        dsci_inv=dsc_inv(itypi)
1737         dsci_inv=vbld_inv(i+nres)
1738 !
1739 ! Calculate SC interaction energy.
1740 !
1741         do iint=1,nint_gr(i)
1742           do j=istart(i,iint),iend(i,iint)
1743 !el            ind=ind+1
1744             itypj=iabs(itype(j,1))
1745             if (itypj.eq.ntyp1) cycle
1746 !            dscj_inv=dsc_inv(itypj)
1747             dscj_inv=vbld_inv(j+nres)
1748             chi1=chi(itypi,itypj)
1749             chi2=chi(itypj,itypi)
1750             chi12=chi1*chi2
1751             chip1=chip(itypi)
1752             chip2=chip(itypj)
1753             chip12=chip1*chip2
1754             alf1=alp(itypi)
1755             alf2=alp(itypj)
1756             alf12=0.5D0*(alf1+alf2)
1757 ! For diagnostics only!!!
1758 !           chi1=0.0D0
1759 !           chi2=0.0D0
1760 !           chi12=0.0D0
1761 !           chip1=0.0D0
1762 !           chip2=0.0D0
1763 !           chip12=0.0D0
1764 !           alf1=0.0D0
1765 !           alf2=0.0D0
1766 !           alf12=0.0D0
1767             xj=c(1,nres+j)-xi
1768             yj=c(2,nres+j)-yi
1769             zj=c(3,nres+j)-zi
1770             dxj=dc_norm(1,nres+j)
1771             dyj=dc_norm(2,nres+j)
1772             dzj=dc_norm(3,nres+j)
1773             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1774 !d          if (icall.eq.0) then
1775 !d            rrsave(ind)=rrij
1776 !d          else
1777 !d            rrij=rrsave(ind)
1778 !d          endif
1779             rij=dsqrt(rrij)
1780 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1781             call sc_angular
1782 ! Calculate whole angle-dependent part of epsilon and contributions
1783 ! to its derivatives
1784             fac=(rrij*sigsq)**expon2
1785             e1=fac*fac*aa_aq(itypi,itypj)
1786             e2=fac*bb_aq(itypi,itypj)
1787             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1788             eps2der=evdwij*eps3rt
1789             eps3der=evdwij*eps2rt
1790             evdwij=evdwij*eps2rt*eps3rt
1791             evdw=evdw+evdwij
1792             if (lprn) then
1793             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1794             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1795 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1796 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1797 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1798 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1799 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1800 !d     &        evdwij
1801             endif
1802 ! Calculate gradient components.
1803             e1=e1*eps1*eps2rt**2*eps3rt**2
1804             fac=-expon*(e1+evdwij)
1805             sigder=fac/sigsq
1806             fac=rrij*fac
1807 ! Calculate radial part of the gradient
1808             gg(1)=xj*fac
1809             gg(2)=yj*fac
1810             gg(3)=zj*fac
1811 ! Calculate the angular part of the gradient and sum add the contributions
1812 ! to the appropriate components of the Cartesian gradient.
1813             call sc_grad
1814           enddo      ! j
1815         enddo        ! iint
1816       enddo          ! i
1817 !     stop
1818       return
1819       end subroutine ebp
1820 !-----------------------------------------------------------------------------
1821       subroutine egb(evdw)
1822 !
1823 ! This subroutine calculates the interaction energy of nonbonded side chains
1824 ! assuming the Gay-Berne potential of interaction.
1825 !
1826       use calc_data
1827 !      implicit real*8 (a-h,o-z)
1828 !      include 'DIMENSIONS'
1829 !      include 'COMMON.GEO'
1830 !      include 'COMMON.VAR'
1831 !      include 'COMMON.LOCAL'
1832 !      include 'COMMON.CHAIN'
1833 !      include 'COMMON.DERIV'
1834 !      include 'COMMON.NAMES'
1835 !      include 'COMMON.INTERACT'
1836 !      include 'COMMON.IOUNITS'
1837 !      include 'COMMON.CALC'
1838 !      include 'COMMON.CONTROL'
1839 !      include 'COMMON.SBRIDGE'
1840       logical :: lprn
1841 !el local variables
1842       integer :: iint,itypi,itypi1,itypj,subchap,icont
1843       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1844       real(kind=8) :: evdw,sig0ij
1845       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1846                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1847                     sslipi,sslipj,faclip
1848       integer :: ii
1849       real(kind=8) :: fracinbuf
1850
1851 !cccc      energy_dec=.false.
1852 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1853       evdw=0.0D0
1854       lprn=.false.
1855 !     if (icall.eq.0) lprn=.false.
1856 !el      ind=0
1857       dCAVdOM2=0.0d0
1858       dGCLdOM2=0.0d0
1859       dPOLdOM2=0.0d0
1860       dCAVdOM1=0.0d0
1861       dGCLdOM1=0.0d0
1862       dPOLdOM1=0.0d0
1863
1864
1865       do icont=g_listscsc_start,g_listscsc_end
1866       i=newcontlisti(icont)
1867       j=newcontlistj(icont)
1868
1869 !      do i=iatsc_s,iatsc_e
1870 !C        print *,"I am in EVDW",i
1871         itypi=iabs(itype(i,1))
1872 !        if (i.ne.47) cycle
1873         if (itypi.eq.ntyp1) cycle
1874         itypi1=iabs(itype(i+1,1))
1875         xi=c(1,nres+i)
1876         yi=c(2,nres+i)
1877         zi=c(3,nres+i)
1878           xi=dmod(xi,boxxsize)
1879           if (xi.lt.0) xi=xi+boxxsize
1880           yi=dmod(yi,boxysize)
1881           if (yi.lt.0) yi=yi+boxysize
1882           zi=dmod(zi,boxzsize)
1883           if (zi.lt.0) zi=zi+boxzsize
1884
1885        if ((zi.gt.bordlipbot)  &
1886         .and.(zi.lt.bordliptop)) then
1887 !C the energy transfer exist
1888         if (zi.lt.buflipbot) then
1889 !C what fraction I am in
1890          fracinbuf=1.0d0-  &
1891               ((zi-bordlipbot)/lipbufthick)
1892 !C lipbufthick is thickenes of lipid buffore
1893          sslipi=sscalelip(fracinbuf)
1894          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1895         elseif (zi.gt.bufliptop) then
1896          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1897          sslipi=sscalelip(fracinbuf)
1898          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1899         else
1900          sslipi=1.0d0
1901          ssgradlipi=0.0
1902         endif
1903        else
1904          sslipi=0.0d0
1905          ssgradlipi=0.0
1906        endif
1907 !       print *, sslipi,ssgradlipi
1908         dxi=dc_norm(1,nres+i)
1909         dyi=dc_norm(2,nres+i)
1910         dzi=dc_norm(3,nres+i)
1911 !        dsci_inv=dsc_inv(itypi)
1912         dsci_inv=vbld_inv(i+nres)
1913 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1914 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1915 !
1916 ! Calculate SC interaction energy.
1917 !
1918 !        do iint=1,nint_gr(i)
1919 !          do j=istart(i,iint),iend(i,iint)
1920             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1921               call dyn_ssbond_ene(i,j,evdwij)
1922               evdw=evdw+evdwij
1923               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1924                               'evdw',i,j,evdwij,' ss'
1925 !              if (energy_dec) write (iout,*) &
1926 !                              'evdw',i,j,evdwij,' ss'
1927              do k=j+1,iend(i,iint)
1928 !C search over all next residues
1929               if (dyn_ss_mask(k)) then
1930 !C check if they are cysteins
1931 !C              write(iout,*) 'k=',k
1932
1933 !c              write(iout,*) "PRZED TRI", evdwij
1934 !               evdwij_przed_tri=evdwij
1935               call triple_ssbond_ene(i,j,k,evdwij)
1936 !c               if(evdwij_przed_tri.ne.evdwij) then
1937 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1938 !c               endif
1939
1940 !c              write(iout,*) "PO TRI", evdwij
1941 !C call the energy function that removes the artifical triple disulfide
1942 !C bond the soubroutine is located in ssMD.F
1943               evdw=evdw+evdwij
1944               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1945                             'evdw',i,j,evdwij,'tss'
1946               endif!dyn_ss_mask(k)
1947              enddo! k
1948             ELSE
1949 !el            ind=ind+1
1950             itypj=iabs(itype(j,1))
1951             if (itypj.eq.ntyp1) cycle
1952 !             if (j.ne.78) cycle
1953 !            dscj_inv=dsc_inv(itypj)
1954             dscj_inv=vbld_inv(j+nres)
1955 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1956 !              1.0d0/vbld(j+nres) !d
1957 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1958             sig0ij=sigma(itypi,itypj)
1959             chi1=chi(itypi,itypj)
1960             chi2=chi(itypj,itypi)
1961             chi12=chi1*chi2
1962             chip1=chip(itypi)
1963             chip2=chip(itypj)
1964             chip12=chip1*chip2
1965             alf1=alp(itypi)
1966             alf2=alp(itypj)
1967             alf12=0.5D0*(alf1+alf2)
1968 ! For diagnostics only!!!
1969 !           chi1=0.0D0
1970 !           chi2=0.0D0
1971 !           chi12=0.0D0
1972 !           chip1=0.0D0
1973 !           chip2=0.0D0
1974 !           chip12=0.0D0
1975 !           alf1=0.0D0
1976 !           alf2=0.0D0
1977 !           alf12=0.0D0
1978            xj=c(1,nres+j)
1979            yj=c(2,nres+j)
1980            zj=c(3,nres+j)
1981           xj=dmod(xj,boxxsize)
1982           if (xj.lt.0) xj=xj+boxxsize
1983           yj=dmod(yj,boxysize)
1984           if (yj.lt.0) yj=yj+boxysize
1985           zj=dmod(zj,boxzsize)
1986           if (zj.lt.0) zj=zj+boxzsize
1987 !          print *,"tu",xi,yi,zi,xj,yj,zj
1988 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1989 ! this fragment set correct epsilon for lipid phase
1990        if ((zj.gt.bordlipbot)  &
1991        .and.(zj.lt.bordliptop)) then
1992 !C the energy transfer exist
1993         if (zj.lt.buflipbot) then
1994 !C what fraction I am in
1995          fracinbuf=1.0d0-     &
1996              ((zj-bordlipbot)/lipbufthick)
1997 !C lipbufthick is thickenes of lipid buffore
1998          sslipj=sscalelip(fracinbuf)
1999          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2000         elseif (zj.gt.bufliptop) then
2001          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2002          sslipj=sscalelip(fracinbuf)
2003          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2004         else
2005          sslipj=1.0d0
2006          ssgradlipj=0.0
2007         endif
2008        else
2009          sslipj=0.0d0
2010          ssgradlipj=0.0
2011        endif
2012       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
2013        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2014       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
2015        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2016 !------------------------------------------------
2017       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2018       xj_safe=xj
2019       yj_safe=yj
2020       zj_safe=zj
2021       subchap=0
2022       do xshift=-1,1
2023       do yshift=-1,1
2024       do zshift=-1,1
2025           xj=xj_safe+xshift*boxxsize
2026           yj=yj_safe+yshift*boxysize
2027           zj=zj_safe+zshift*boxzsize
2028           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2029           if(dist_temp.lt.dist_init) then
2030             dist_init=dist_temp
2031             xj_temp=xj
2032             yj_temp=yj
2033             zj_temp=zj
2034             subchap=1
2035           endif
2036        enddo
2037        enddo
2038        enddo
2039        if (subchap.eq.1) then
2040           xj=xj_temp-xi
2041           yj=yj_temp-yi
2042           zj=zj_temp-zi
2043        else
2044           xj=xj_safe-xi
2045           yj=yj_safe-yi
2046           zj=zj_safe-zi
2047        endif
2048             dxj=dc_norm(1,nres+j)
2049             dyj=dc_norm(2,nres+j)
2050             dzj=dc_norm(3,nres+j)
2051 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2052 !            write (iout,*) "j",j," dc_norm",& !d
2053 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2054 !          write(iout,*)"rrij ",rrij
2055 !          write(iout,*)"xj yj zj ", xj, yj, zj
2056 !          write(iout,*)"xi yi zi ", xi, yi, zi
2057 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2058             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2059             rij=dsqrt(rrij)
2060             sss_ele_cut=sscale_ele(1.0d0/(rij))
2061             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2062 !            print *,sss_ele_cut,sss_ele_grad,&
2063 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2064             if (sss_ele_cut.le.0.0) cycle
2065 ! Calculate angle-dependent terms of energy and contributions to their
2066 ! derivatives.
2067             call sc_angular
2068             sigsq=1.0D0/sigsq
2069             sig=sig0ij*dsqrt(sigsq)
2070             rij_shift=1.0D0/rij-sig+sig0ij
2071 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2072 !            "sig0ij",sig0ij
2073 ! for diagnostics; uncomment
2074 !            rij_shift=1.2*sig0ij
2075 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2076             if (rij_shift.le.0.0D0) then
2077               evdw=1.0D20
2078 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2079 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2080 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2081               return
2082             endif
2083             sigder=-sig*sigsq
2084 !---------------------------------------------------------------
2085             rij_shift=1.0D0/rij_shift
2086             fac=rij_shift**expon
2087             faclip=fac
2088             e1=fac*fac*aa!(itypi,itypj)
2089             e2=fac*bb!(itypi,itypj)
2090             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2091             eps2der=evdwij*eps3rt
2092             eps3der=evdwij*eps2rt
2093 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2094 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2095 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2096             evdwij=evdwij*eps2rt*eps3rt
2097             evdw=evdw+evdwij*sss_ele_cut
2098             if (lprn) then
2099             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2100             epsi=bb**2/aa!(itypi,itypj)
2101             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2102               restyp(itypi,1),i,restyp(itypj,1),j, &
2103               epsi,sigm,chi1,chi2,chip1,chip2, &
2104               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2105               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2106               evdwij
2107             endif
2108
2109             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2110                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2111 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2112 !            if (energy_dec) write (iout,*) &
2113 !                             'evdw',i,j,evdwij
2114 !                       print *,"ZALAMKA", evdw
2115
2116 ! Calculate gradient components.
2117             e1=e1*eps1*eps2rt**2*eps3rt**2
2118             fac=-expon*(e1+evdwij)*rij_shift
2119             sigder=fac*sigder
2120             fac=rij*fac
2121 !            print *,'before fac',fac,rij,evdwij
2122             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2123             *rij
2124 !            print *,'grad part scale',fac,   &
2125 !             evdwij*sss_ele_grad/sss_ele_cut &
2126 !            /sigma(itypi,itypj)*rij
2127 !            fac=0.0d0
2128 ! Calculate the radial part of the gradient
2129             gg(1)=xj*fac
2130             gg(2)=yj*fac
2131             gg(3)=zj*fac
2132 !C Calculate the radial part of the gradient
2133             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2134        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2135         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2136        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2137             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2138             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2139
2140 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2141 ! Calculate angular part of the gradient.
2142             call sc_grad
2143             ENDIF    ! dyn_ss
2144 !          enddo      ! j
2145 !        enddo        ! iint
2146       enddo          ! i
2147 !       print *,"ZALAMKA", evdw
2148 !      write (iout,*) "Number of loop steps in EGB:",ind
2149 !ccc      energy_dec=.false.
2150       return
2151       end subroutine egb
2152 !-----------------------------------------------------------------------------
2153       subroutine egbv(evdw)
2154 !
2155 ! This subroutine calculates the interaction energy of nonbonded side chains
2156 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2157 !
2158       use comm_srutu
2159       use calc_data
2160 !      implicit real*8 (a-h,o-z)
2161 !      include 'DIMENSIONS'
2162 !      include 'COMMON.GEO'
2163 !      include 'COMMON.VAR'
2164 !      include 'COMMON.LOCAL'
2165 !      include 'COMMON.CHAIN'
2166 !      include 'COMMON.DERIV'
2167 !      include 'COMMON.NAMES'
2168 !      include 'COMMON.INTERACT'
2169 !      include 'COMMON.IOUNITS'
2170 !      include 'COMMON.CALC'
2171       use comm_srutu
2172 !el      integer :: icall
2173 !el      common /srutu/ icall
2174       logical :: lprn
2175 !el local variables
2176       integer :: iint,itypi,itypi1,itypj
2177       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2178       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2179
2180 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2181       evdw=0.0D0
2182       lprn=.false.
2183 !     if (icall.eq.0) lprn=.true.
2184 !el      ind=0
2185       do i=iatsc_s,iatsc_e
2186         itypi=iabs(itype(i,1))
2187         if (itypi.eq.ntyp1) cycle
2188         itypi1=iabs(itype(i+1,1))
2189         xi=c(1,nres+i)
2190         yi=c(2,nres+i)
2191         zi=c(3,nres+i)
2192         dxi=dc_norm(1,nres+i)
2193         dyi=dc_norm(2,nres+i)
2194         dzi=dc_norm(3,nres+i)
2195 !        dsci_inv=dsc_inv(itypi)
2196         dsci_inv=vbld_inv(i+nres)
2197 !
2198 ! Calculate SC interaction energy.
2199 !
2200         do iint=1,nint_gr(i)
2201           do j=istart(i,iint),iend(i,iint)
2202 !el            ind=ind+1
2203             itypj=iabs(itype(j,1))
2204             if (itypj.eq.ntyp1) cycle
2205 !            dscj_inv=dsc_inv(itypj)
2206             dscj_inv=vbld_inv(j+nres)
2207             sig0ij=sigma(itypi,itypj)
2208             r0ij=r0(itypi,itypj)
2209             chi1=chi(itypi,itypj)
2210             chi2=chi(itypj,itypi)
2211             chi12=chi1*chi2
2212             chip1=chip(itypi)
2213             chip2=chip(itypj)
2214             chip12=chip1*chip2
2215             alf1=alp(itypi)
2216             alf2=alp(itypj)
2217             alf12=0.5D0*(alf1+alf2)
2218 ! For diagnostics only!!!
2219 !           chi1=0.0D0
2220 !           chi2=0.0D0
2221 !           chi12=0.0D0
2222 !           chip1=0.0D0
2223 !           chip2=0.0D0
2224 !           chip12=0.0D0
2225 !           alf1=0.0D0
2226 !           alf2=0.0D0
2227 !           alf12=0.0D0
2228             xj=c(1,nres+j)-xi
2229             yj=c(2,nres+j)-yi
2230             zj=c(3,nres+j)-zi
2231             dxj=dc_norm(1,nres+j)
2232             dyj=dc_norm(2,nres+j)
2233             dzj=dc_norm(3,nres+j)
2234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2235             rij=dsqrt(rrij)
2236 ! Calculate angle-dependent terms of energy and contributions to their
2237 ! derivatives.
2238             call sc_angular
2239             sigsq=1.0D0/sigsq
2240             sig=sig0ij*dsqrt(sigsq)
2241             rij_shift=1.0D0/rij-sig+r0ij
2242 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2243             if (rij_shift.le.0.0D0) then
2244               evdw=1.0D20
2245               return
2246             endif
2247             sigder=-sig*sigsq
2248 !---------------------------------------------------------------
2249             rij_shift=1.0D0/rij_shift
2250             fac=rij_shift**expon
2251             e1=fac*fac*aa_aq(itypi,itypj)
2252             e2=fac*bb_aq(itypi,itypj)
2253             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2254             eps2der=evdwij*eps3rt
2255             eps3der=evdwij*eps2rt
2256             fac_augm=rrij**expon
2257             e_augm=augm(itypi,itypj)*fac_augm
2258             evdwij=evdwij*eps2rt*eps3rt
2259             evdw=evdw+evdwij+e_augm
2260             if (lprn) then
2261             sigm=dabs(aa_aq(itypi,itypj)/&
2262             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2263             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2264             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2265               restyp(itypi,1),i,restyp(itypj,1),j,&
2266               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2267               chi1,chi2,chip1,chip2,&
2268               eps1,eps2rt**2,eps3rt**2,&
2269               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2270               evdwij+e_augm
2271             endif
2272 ! Calculate gradient components.
2273             e1=e1*eps1*eps2rt**2*eps3rt**2
2274             fac=-expon*(e1+evdwij)*rij_shift
2275             sigder=fac*sigder
2276             fac=rij*fac-2*expon*rrij*e_augm
2277 ! Calculate the radial part of the gradient
2278             gg(1)=xj*fac
2279             gg(2)=yj*fac
2280             gg(3)=zj*fac
2281 ! Calculate angular part of the gradient.
2282             call sc_grad
2283           enddo      ! j
2284         enddo        ! iint
2285       enddo          ! i
2286       end subroutine egbv
2287 !-----------------------------------------------------------------------------
2288 !el      subroutine sc_angular in module geometry
2289 !-----------------------------------------------------------------------------
2290       subroutine e_softsphere(evdw)
2291 !
2292 ! This subroutine calculates the interaction energy of nonbonded side chains
2293 ! assuming the LJ potential of interaction.
2294 !
2295 !      implicit real*8 (a-h,o-z)
2296 !      include 'DIMENSIONS'
2297       real(kind=8),parameter :: accur=1.0d-10
2298 !      include 'COMMON.GEO'
2299 !      include 'COMMON.VAR'
2300 !      include 'COMMON.LOCAL'
2301 !      include 'COMMON.CHAIN'
2302 !      include 'COMMON.DERIV'
2303 !      include 'COMMON.INTERACT'
2304 !      include 'COMMON.TORSION'
2305 !      include 'COMMON.SBRIDGE'
2306 !      include 'COMMON.NAMES'
2307 !      include 'COMMON.IOUNITS'
2308 !      include 'COMMON.CONTACTS'
2309       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2310 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2311 !el local variables
2312       integer :: i,iint,j,itypi,itypi1,itypj,k
2313       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2314       real(kind=8) :: fac
2315
2316       evdw=0.0D0
2317       do i=iatsc_s,iatsc_e
2318         itypi=iabs(itype(i,1))
2319         if (itypi.eq.ntyp1) cycle
2320         itypi1=iabs(itype(i+1,1))
2321         xi=c(1,nres+i)
2322         yi=c(2,nres+i)
2323         zi=c(3,nres+i)
2324 !
2325 ! Calculate SC interaction energy.
2326 !
2327         do iint=1,nint_gr(i)
2328 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2329 !d   &                  'iend=',iend(i,iint)
2330           do j=istart(i,iint),iend(i,iint)
2331             itypj=iabs(itype(j,1))
2332             if (itypj.eq.ntyp1) cycle
2333             xj=c(1,nres+j)-xi
2334             yj=c(2,nres+j)-yi
2335             zj=c(3,nres+j)-zi
2336             rij=xj*xj+yj*yj+zj*zj
2337 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2338             r0ij=r0(itypi,itypj)
2339             r0ijsq=r0ij*r0ij
2340 !            print *,i,j,r0ij,dsqrt(rij)
2341             if (rij.lt.r0ijsq) then
2342               evdwij=0.25d0*(rij-r0ijsq)**2
2343               fac=rij-r0ijsq
2344             else
2345               evdwij=0.0d0
2346               fac=0.0d0
2347             endif
2348             evdw=evdw+evdwij
2349 !
2350 ! Calculate the components of the gradient in DC and X
2351 !
2352             gg(1)=xj*fac
2353             gg(2)=yj*fac
2354             gg(3)=zj*fac
2355             do k=1,3
2356               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2357               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2358               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2359               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2360             enddo
2361 !grad            do k=i,j-1
2362 !grad              do l=1,3
2363 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2364 !grad              enddo
2365 !grad            enddo
2366           enddo ! j
2367         enddo ! iint
2368       enddo ! i
2369       return
2370       end subroutine e_softsphere
2371 !-----------------------------------------------------------------------------
2372       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2373 !
2374 ! Soft-sphere potential of p-p interaction
2375 !
2376 !      implicit real*8 (a-h,o-z)
2377 !      include 'DIMENSIONS'
2378 !      include 'COMMON.CONTROL'
2379 !      include 'COMMON.IOUNITS'
2380 !      include 'COMMON.GEO'
2381 !      include 'COMMON.VAR'
2382 !      include 'COMMON.LOCAL'
2383 !      include 'COMMON.CHAIN'
2384 !      include 'COMMON.DERIV'
2385 !      include 'COMMON.INTERACT'
2386 !      include 'COMMON.CONTACTS'
2387 !      include 'COMMON.TORSION'
2388 !      include 'COMMON.VECTORS'
2389 !      include 'COMMON.FFIELD'
2390       real(kind=8),dimension(3) :: ggg
2391 !d      write(iout,*) 'In EELEC_soft_sphere'
2392 !el local variables
2393       integer :: i,j,k,num_conti,iteli,itelj
2394       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2395       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2396       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2397
2398       ees=0.0D0
2399       evdw1=0.0D0
2400       eel_loc=0.0d0
2401       eello_turn3=0.0d0
2402       eello_turn4=0.0d0
2403 !el      ind=0
2404       do i=iatel_s,iatel_e
2405         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2406         dxi=dc(1,i)
2407         dyi=dc(2,i)
2408         dzi=dc(3,i)
2409         xmedi=c(1,i)+0.5d0*dxi
2410         ymedi=c(2,i)+0.5d0*dyi
2411         zmedi=c(3,i)+0.5d0*dzi
2412         num_conti=0
2413 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2414         do j=ielstart(i),ielend(i)
2415           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2416 !el          ind=ind+1
2417           iteli=itel(i)
2418           itelj=itel(j)
2419           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2420           r0ij=rpp(iteli,itelj)
2421           r0ijsq=r0ij*r0ij
2422           dxj=dc(1,j)
2423           dyj=dc(2,j)
2424           dzj=dc(3,j)
2425           xj=c(1,j)+0.5D0*dxj-xmedi
2426           yj=c(2,j)+0.5D0*dyj-ymedi
2427           zj=c(3,j)+0.5D0*dzj-zmedi
2428           rij=xj*xj+yj*yj+zj*zj
2429           if (rij.lt.r0ijsq) then
2430             evdw1ij=0.25d0*(rij-r0ijsq)**2
2431             fac=rij-r0ijsq
2432           else
2433             evdw1ij=0.0d0
2434             fac=0.0d0
2435           endif
2436           evdw1=evdw1+evdw1ij
2437 !
2438 ! Calculate contributions to the Cartesian gradient.
2439 !
2440           ggg(1)=fac*xj
2441           ggg(2)=fac*yj
2442           ggg(3)=fac*zj
2443           do k=1,3
2444             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2445             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2446           enddo
2447 !
2448 ! Loop over residues i+1 thru j-1.
2449 !
2450 !grad          do k=i+1,j-1
2451 !grad            do l=1,3
2452 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2453 !grad            enddo
2454 !grad          enddo
2455         enddo ! j
2456       enddo   ! i
2457 !grad      do i=nnt,nct-1
2458 !grad        do k=1,3
2459 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2460 !grad        enddo
2461 !grad        do j=i+1,nct-1
2462 !grad          do k=1,3
2463 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2464 !grad          enddo
2465 !grad        enddo
2466 !grad      enddo
2467       return
2468       end subroutine eelec_soft_sphere
2469 !-----------------------------------------------------------------------------
2470       subroutine vec_and_deriv
2471 !      implicit real*8 (a-h,o-z)
2472 !      include 'DIMENSIONS'
2473 #ifdef MPI
2474       include 'mpif.h'
2475 #endif
2476 !      include 'COMMON.IOUNITS'
2477 !      include 'COMMON.GEO'
2478 !      include 'COMMON.VAR'
2479 !      include 'COMMON.LOCAL'
2480 !      include 'COMMON.CHAIN'
2481 !      include 'COMMON.VECTORS'
2482 !      include 'COMMON.SETUP'
2483 !      include 'COMMON.TIME1'
2484       real(kind=8),dimension(3,3,2) :: uyder,uzder
2485       real(kind=8),dimension(2) :: vbld_inv_temp
2486 ! Compute the local reference systems. For reference system (i), the
2487 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2488 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2489 !el local variables
2490       integer :: i,j,k,l
2491       real(kind=8) :: facy,fac,costh
2492
2493 #ifdef PARVEC
2494       do i=ivec_start,ivec_end
2495 #else
2496       do i=1,nres-1
2497 #endif
2498           if (i.eq.nres-1) then
2499 ! Case of the last full residue
2500 ! Compute the Z-axis
2501             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2502             costh=dcos(pi-theta(nres))
2503             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2504             do k=1,3
2505               uz(k,i)=fac*uz(k,i)
2506             enddo
2507 ! Compute the derivatives of uz
2508             uzder(1,1,1)= 0.0d0
2509             uzder(2,1,1)=-dc_norm(3,i-1)
2510             uzder(3,1,1)= dc_norm(2,i-1)
2511             uzder(1,2,1)= dc_norm(3,i-1)
2512             uzder(2,2,1)= 0.0d0
2513             uzder(3,2,1)=-dc_norm(1,i-1)
2514             uzder(1,3,1)=-dc_norm(2,i-1)
2515             uzder(2,3,1)= dc_norm(1,i-1)
2516             uzder(3,3,1)= 0.0d0
2517             uzder(1,1,2)= 0.0d0
2518             uzder(2,1,2)= dc_norm(3,i)
2519             uzder(3,1,2)=-dc_norm(2,i)
2520             uzder(1,2,2)=-dc_norm(3,i)
2521             uzder(2,2,2)= 0.0d0
2522             uzder(3,2,2)= dc_norm(1,i)
2523             uzder(1,3,2)= dc_norm(2,i)
2524             uzder(2,3,2)=-dc_norm(1,i)
2525             uzder(3,3,2)= 0.0d0
2526 ! Compute the Y-axis
2527             facy=fac
2528             do k=1,3
2529               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2530             enddo
2531 ! Compute the derivatives of uy
2532             do j=1,3
2533               do k=1,3
2534                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2535                               -dc_norm(k,i)*dc_norm(j,i-1)
2536                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2537               enddo
2538               uyder(j,j,1)=uyder(j,j,1)-costh
2539               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2540             enddo
2541             do j=1,2
2542               do k=1,3
2543                 do l=1,3
2544                   uygrad(l,k,j,i)=uyder(l,k,j)
2545                   uzgrad(l,k,j,i)=uzder(l,k,j)
2546                 enddo
2547               enddo
2548             enddo
2549             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2550             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2551             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2552             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2553           else
2554 ! Other residues
2555 ! Compute the Z-axis
2556             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2557             costh=dcos(pi-theta(i+2))
2558             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2559             do k=1,3
2560               uz(k,i)=fac*uz(k,i)
2561             enddo
2562 ! Compute the derivatives of uz
2563             uzder(1,1,1)= 0.0d0
2564             uzder(2,1,1)=-dc_norm(3,i+1)
2565             uzder(3,1,1)= dc_norm(2,i+1)
2566             uzder(1,2,1)= dc_norm(3,i+1)
2567             uzder(2,2,1)= 0.0d0
2568             uzder(3,2,1)=-dc_norm(1,i+1)
2569             uzder(1,3,1)=-dc_norm(2,i+1)
2570             uzder(2,3,1)= dc_norm(1,i+1)
2571             uzder(3,3,1)= 0.0d0
2572             uzder(1,1,2)= 0.0d0
2573             uzder(2,1,2)= dc_norm(3,i)
2574             uzder(3,1,2)=-dc_norm(2,i)
2575             uzder(1,2,2)=-dc_norm(3,i)
2576             uzder(2,2,2)= 0.0d0
2577             uzder(3,2,2)= dc_norm(1,i)
2578             uzder(1,3,2)= dc_norm(2,i)
2579             uzder(2,3,2)=-dc_norm(1,i)
2580             uzder(3,3,2)= 0.0d0
2581 ! Compute the Y-axis
2582             facy=fac
2583             do k=1,3
2584               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2585             enddo
2586 ! Compute the derivatives of uy
2587             do j=1,3
2588               do k=1,3
2589                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2590                               -dc_norm(k,i)*dc_norm(j,i+1)
2591                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2592               enddo
2593               uyder(j,j,1)=uyder(j,j,1)-costh
2594               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2595             enddo
2596             do j=1,2
2597               do k=1,3
2598                 do l=1,3
2599                   uygrad(l,k,j,i)=uyder(l,k,j)
2600                   uzgrad(l,k,j,i)=uzder(l,k,j)
2601                 enddo
2602               enddo
2603             enddo
2604             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2605             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2606             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2607             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2608           endif
2609       enddo
2610       do i=1,nres-1
2611         vbld_inv_temp(1)=vbld_inv(i+1)
2612         if (i.lt.nres-1) then
2613           vbld_inv_temp(2)=vbld_inv(i+2)
2614           else
2615           vbld_inv_temp(2)=vbld_inv(i)
2616           endif
2617         do j=1,2
2618           do k=1,3
2619             do l=1,3
2620               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2621               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2622             enddo
2623           enddo
2624         enddo
2625       enddo
2626 #if defined(PARVEC) && defined(MPI)
2627       if (nfgtasks1.gt.1) then
2628         time00=MPI_Wtime()
2629 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2630 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2631 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2632         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2633          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2634          FG_COMM1,IERR)
2635         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2636          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2637          FG_COMM1,IERR)
2638         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2639          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2640          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2641         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2642          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2643          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2644         time_gather=time_gather+MPI_Wtime()-time00
2645       endif
2646 !      if (fg_rank.eq.0) then
2647 !        write (iout,*) "Arrays UY and UZ"
2648 !        do i=1,nres-1
2649 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2650 !     &     (uz(k,i),k=1,3)
2651 !        enddo
2652 !      endif
2653 #endif
2654       return
2655       end subroutine vec_and_deriv
2656 !-----------------------------------------------------------------------------
2657       subroutine check_vecgrad
2658 !      implicit real*8 (a-h,o-z)
2659 !      include 'DIMENSIONS'
2660 !      include 'COMMON.IOUNITS'
2661 !      include 'COMMON.GEO'
2662 !      include 'COMMON.VAR'
2663 !      include 'COMMON.LOCAL'
2664 !      include 'COMMON.CHAIN'
2665 !      include 'COMMON.VECTORS'
2666       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2667       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2668       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2669       real(kind=8),dimension(3) :: erij
2670       real(kind=8) :: delta=1.0d-7
2671 !el local variables
2672       integer :: i,j,k,l
2673
2674       call vec_and_deriv
2675 !d      do i=1,nres
2676 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2677 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2678 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2679 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2680 !d     &     (dc_norm(if90,i),if90=1,3)
2681 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2682 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2683 !d          write(iout,'(a)')
2684 !d      enddo
2685       do i=1,nres
2686         do j=1,2
2687           do k=1,3
2688             do l=1,3
2689               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2690               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2691             enddo
2692           enddo
2693         enddo
2694       enddo
2695       call vec_and_deriv
2696       do i=1,nres
2697         do j=1,3
2698           uyt(j,i)=uy(j,i)
2699           uzt(j,i)=uz(j,i)
2700         enddo
2701       enddo
2702       do i=1,nres
2703 !d        write (iout,*) 'i=',i
2704         do k=1,3
2705           erij(k)=dc_norm(k,i)
2706         enddo
2707         do j=1,3
2708           do k=1,3
2709             dc_norm(k,i)=erij(k)
2710           enddo
2711           dc_norm(j,i)=dc_norm(j,i)+delta
2712 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2713 !          do k=1,3
2714 !            dc_norm(k,i)=dc_norm(k,i)/fac
2715 !          enddo
2716 !          write (iout,*) (dc_norm(k,i),k=1,3)
2717 !          write (iout,*) (erij(k),k=1,3)
2718           call vec_and_deriv
2719           do k=1,3
2720             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2721             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2722             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2723             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2724           enddo
2725 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2726 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2727 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2728         enddo
2729         do k=1,3
2730           dc_norm(k,i)=erij(k)
2731         enddo
2732 !d        do k=1,3
2733 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2734 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2735 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2736 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2737 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2738 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2739 !d          write (iout,'(a)')
2740 !d        enddo
2741       enddo
2742       return
2743       end subroutine check_vecgrad
2744 !-----------------------------------------------------------------------------
2745       subroutine set_matrices
2746 !      implicit real*8 (a-h,o-z)
2747 !      include 'DIMENSIONS'
2748 #ifdef MPI
2749       include "mpif.h"
2750 !      include "COMMON.SETUP"
2751       integer :: IERR
2752       integer :: status(MPI_STATUS_SIZE)
2753 #endif
2754 !      include 'COMMON.IOUNITS'
2755 !      include 'COMMON.GEO'
2756 !      include 'COMMON.VAR'
2757 !      include 'COMMON.LOCAL'
2758 !      include 'COMMON.CHAIN'
2759 !      include 'COMMON.DERIV'
2760 !      include 'COMMON.INTERACT'
2761 !      include 'COMMON.CONTACTS'
2762 !      include 'COMMON.TORSION'
2763 !      include 'COMMON.VECTORS'
2764 !      include 'COMMON.FFIELD'
2765       real(kind=8) :: auxvec(2),auxmat(2,2)
2766       integer :: i,iti1,iti,k,l
2767       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2768        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2769 !       print *,"in set matrices"
2770 !
2771 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2772 ! to calculate the el-loc multibody terms of various order.
2773 !
2774 !AL el      mu=0.0d0
2775
2776 #ifdef PARMAT
2777       do i=ivec_start+2,ivec_end+2
2778 #else
2779       do i=3,nres+1
2780 #endif
2781         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2782           if (itype(i-2,1).eq.0) then
2783           iti = nloctyp
2784           else
2785           iti = itype2loc(itype(i-2,1))
2786           endif
2787         else
2788           iti=nloctyp
2789         endif
2790 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2791         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2792           iti1 = itype2loc(itype(i-1,1))
2793         else
2794           iti1=nloctyp
2795         endif
2796 !        print *,i,itype(i-2,1),iti
2797 #ifdef NEWCORR
2798         cost1=dcos(theta(i-1))
2799         sint1=dsin(theta(i-1))
2800         sint1sq=sint1*sint1
2801         sint1cub=sint1sq*sint1
2802         sint1cost1=2*sint1*cost1
2803 !        print *,"cost1",cost1,theta(i-1)
2804 !c        write (iout,*) "bnew1",i,iti
2805 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2806 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2807 !c        write (iout,*) "bnew2",i,iti
2808 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2809 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2810         k=1
2811 !        print *,bnew1(1,k,iti),"bnew1"
2812         do k=1,2
2813           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2814 !          print *,b1k
2815 !          write(*,*) shape(b1)
2816 !          if(.not.allocated(b1)) print *, "WTF?"
2817           b1(k,i-2)=sint1*b1k
2818 !
2819 !             print *,b1(k,i-2)
2820
2821           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2822                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2823 !             print *,gtb1(k,i-2)
2824
2825           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2826           b2(k,i-2)=sint1*b2k
2827 !             print *,b2(k,i-2)
2828
2829           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2830                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2831 !             print *,gtb2(k,i-2)
2832
2833         enddo
2834 !        print *,b1k,b2k
2835         do k=1,2
2836           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2837           cc(1,k,i-2)=sint1sq*aux
2838           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2839                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2840           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2841           dd(1,k,i-2)=sint1sq*aux
2842           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2843                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2844         enddo
2845 !        print *,"after cc"
2846         cc(2,1,i-2)=cc(1,2,i-2)
2847         cc(2,2,i-2)=-cc(1,1,i-2)
2848         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2849         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2850         dd(2,1,i-2)=dd(1,2,i-2)
2851         dd(2,2,i-2)=-dd(1,1,i-2)
2852         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2853         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2854 !        print *,"after dd"
2855
2856         do k=1,2
2857           do l=1,2
2858             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2859             EE(l,k,i-2)=sint1sq*aux
2860             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2861           enddo
2862         enddo
2863         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2864         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2865         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2866         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2867         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2868         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2869         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2870 !        print *,"after ee"
2871
2872 !c        b1tilde(1,i-2)=b1(1,i-2)
2873 !c        b1tilde(2,i-2)=-b1(2,i-2)
2874 !c        b2tilde(1,i-2)=b2(1,i-2)
2875 !c        b2tilde(2,i-2)=-b2(2,i-2)
2876 #ifdef DEBUG
2877         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2878         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2879         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2880         write (iout,*) 'theta=', theta(i-1)
2881 #endif
2882 #else
2883         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2884 !         write(iout,*) "i,",molnum(i),nloctyp
2885 !         print *, "i,",molnum(i),i,itype(i-2,1)
2886         if (molnum(i).eq.1) then
2887           if (itype(i-2,1).eq.ntyp1) then
2888            iti=nloctyp
2889           else
2890           iti = itype2loc(itype(i-2,1))
2891           endif
2892         else
2893           iti=nloctyp
2894         endif
2895         else
2896           iti=nloctyp
2897         endif
2898 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2899 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2900         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2901           iti1 = itype2loc(itype(i-1,1))
2902         else
2903           iti1=nloctyp
2904         endif
2905 !        print *,i,iti
2906         b1(1,i-2)=b(3,iti)
2907         b1(2,i-2)=b(5,iti)
2908         b2(1,i-2)=b(2,iti)
2909         b2(2,i-2)=b(4,iti)
2910         do k=1,2
2911           do l=1,2
2912            CC(k,l,i-2)=ccold(k,l,iti)
2913            DD(k,l,i-2)=ddold(k,l,iti)
2914            EE(k,l,i-2)=eeold(k,l,iti)
2915           enddo
2916         enddo
2917 #endif
2918         b1tilde(1,i-2)= b1(1,i-2)
2919         b1tilde(2,i-2)=-b1(2,i-2)
2920         b2tilde(1,i-2)= b2(1,i-2)
2921         b2tilde(2,i-2)=-b2(2,i-2)
2922 !c
2923         Ctilde(1,1,i-2)= CC(1,1,i-2)
2924         Ctilde(1,2,i-2)= CC(1,2,i-2)
2925         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2926         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2927 !c
2928         Dtilde(1,1,i-2)= DD(1,1,i-2)
2929         Dtilde(1,2,i-2)= DD(1,2,i-2)
2930         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2931         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2932       enddo
2933 #ifdef PARMAT
2934       do i=ivec_start+2,ivec_end+2
2935 #else
2936       do i=3,nres+1
2937 #endif
2938
2939 !      print *,i,"i"
2940         if (i .lt. nres+1) then
2941           sin1=dsin(phi(i))
2942           cos1=dcos(phi(i))
2943           sintab(i-2)=sin1
2944           costab(i-2)=cos1
2945           obrot(1,i-2)=cos1
2946           obrot(2,i-2)=sin1
2947           sin2=dsin(2*phi(i))
2948           cos2=dcos(2*phi(i))
2949           sintab2(i-2)=sin2
2950           costab2(i-2)=cos2
2951           obrot2(1,i-2)=cos2
2952           obrot2(2,i-2)=sin2
2953           Ug(1,1,i-2)=-cos1
2954           Ug(1,2,i-2)=-sin1
2955           Ug(2,1,i-2)=-sin1
2956           Ug(2,2,i-2)= cos1
2957           Ug2(1,1,i-2)=-cos2
2958           Ug2(1,2,i-2)=-sin2
2959           Ug2(2,1,i-2)=-sin2
2960           Ug2(2,2,i-2)= cos2
2961         else
2962           costab(i-2)=1.0d0
2963           sintab(i-2)=0.0d0
2964           obrot(1,i-2)=1.0d0
2965           obrot(2,i-2)=0.0d0
2966           obrot2(1,i-2)=0.0d0
2967           obrot2(2,i-2)=0.0d0
2968           Ug(1,1,i-2)=1.0d0
2969           Ug(1,2,i-2)=0.0d0
2970           Ug(2,1,i-2)=0.0d0
2971           Ug(2,2,i-2)=1.0d0
2972           Ug2(1,1,i-2)=0.0d0
2973           Ug2(1,2,i-2)=0.0d0
2974           Ug2(2,1,i-2)=0.0d0
2975           Ug2(2,2,i-2)=0.0d0
2976         endif
2977         if (i .gt. 3 .and. i .lt. nres+1) then
2978           obrot_der(1,i-2)=-sin1
2979           obrot_der(2,i-2)= cos1
2980           Ugder(1,1,i-2)= sin1
2981           Ugder(1,2,i-2)=-cos1
2982           Ugder(2,1,i-2)=-cos1
2983           Ugder(2,2,i-2)=-sin1
2984           dwacos2=cos2+cos2
2985           dwasin2=sin2+sin2
2986           obrot2_der(1,i-2)=-dwasin2
2987           obrot2_der(2,i-2)= dwacos2
2988           Ug2der(1,1,i-2)= dwasin2
2989           Ug2der(1,2,i-2)=-dwacos2
2990           Ug2der(2,1,i-2)=-dwacos2
2991           Ug2der(2,2,i-2)=-dwasin2
2992         else
2993           obrot_der(1,i-2)=0.0d0
2994           obrot_der(2,i-2)=0.0d0
2995           Ugder(1,1,i-2)=0.0d0
2996           Ugder(1,2,i-2)=0.0d0
2997           Ugder(2,1,i-2)=0.0d0
2998           Ugder(2,2,i-2)=0.0d0
2999           obrot2_der(1,i-2)=0.0d0
3000           obrot2_der(2,i-2)=0.0d0
3001           Ug2der(1,1,i-2)=0.0d0
3002           Ug2der(1,2,i-2)=0.0d0
3003           Ug2der(2,1,i-2)=0.0d0
3004           Ug2der(2,2,i-2)=0.0d0
3005         endif
3006 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3007         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3008            if (itype(i-2,1).eq.0) then
3009           iti=ntortyp+1
3010            else
3011           iti = itype2loc(itype(i-2,1))
3012            endif
3013         else
3014           iti=nloctyp
3015         endif
3016 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3017         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3018            if (itype(i-1,1).eq.0) then
3019           iti1=nloctyp
3020            else
3021           iti1 = itype2loc(itype(i-1,1))
3022            endif
3023         else
3024           iti1=nloctyp
3025         endif
3026 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3027 !d        write (iout,*) '*******i',i,' iti1',iti
3028 !        write (iout,*) 'b1',b1(:,iti)
3029 !        write (iout,*) 'b2',b2(:,i-2)
3030 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3031 !        if (i .gt. iatel_s+2) then
3032         if (i .gt. nnt+2) then
3033           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3034 #ifdef NEWCORR
3035           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3036 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3037 #endif
3038
3039           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3040           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3041           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3042           then
3043           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3044           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3045           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3046           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3047           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3048           endif
3049         else
3050           do k=1,2
3051             Ub2(k,i-2)=0.0d0
3052             Ctobr(k,i-2)=0.0d0
3053             Dtobr2(k,i-2)=0.0d0
3054             do l=1,2
3055               EUg(l,k,i-2)=0.0d0
3056               CUg(l,k,i-2)=0.0d0
3057               DUg(l,k,i-2)=0.0d0
3058               DtUg2(l,k,i-2)=0.0d0
3059             enddo
3060           enddo
3061         endif
3062         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3063         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3064         do k=1,2
3065           muder(k,i-2)=Ub2der(k,i-2)
3066         enddo
3067 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3068         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3069           if (itype(i-1,1).eq.0) then
3070            iti1=nloctyp
3071           elseif (itype(i-1,1).le.ntyp) then
3072             iti1 = itype2loc(itype(i-1,1))
3073           else
3074             iti1=nloctyp
3075           endif
3076         else
3077           iti1=nloctyp
3078         endif
3079         do k=1,2
3080           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3081         enddo
3082         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3083         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3084         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3085 !d        write (iout,*) 'mu1',mu1(:,i-2)
3086 !d        write (iout,*) 'mu2',mu2(:,i-2)
3087         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3088         then
3089         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3090         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3091         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3092         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3093         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3094 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3095         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3096         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3097         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3098         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3099         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3100         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3101         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3102         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3103         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3104         endif
3105       enddo
3106 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3107 ! The order of matrices is from left to right.
3108       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3109       then
3110 !      do i=max0(ivec_start,2),ivec_end
3111       do i=2,nres-1
3112         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3113         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3114         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3115         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3116         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3117         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3118         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3119         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3120       enddo
3121       endif
3122 #if defined(MPI) && defined(PARMAT)
3123 #ifdef DEBUG
3124 !      if (fg_rank.eq.0) then
3125         write (iout,*) "Arrays UG and UGDER before GATHER"
3126         do i=1,nres-1
3127           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3128            ((ug(l,k,i),l=1,2),k=1,2),&
3129            ((ugder(l,k,i),l=1,2),k=1,2)
3130         enddo
3131         write (iout,*) "Arrays UG2 and UG2DER"
3132         do i=1,nres-1
3133           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3134            ((ug2(l,k,i),l=1,2),k=1,2),&
3135            ((ug2der(l,k,i),l=1,2),k=1,2)
3136         enddo
3137         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3138         do i=1,nres-1
3139           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3140            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3141            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3142         enddo
3143         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3144         do i=1,nres-1
3145           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3146            costab(i),sintab(i),costab2(i),sintab2(i)
3147         enddo
3148         write (iout,*) "Array MUDER"
3149         do i=1,nres-1
3150           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3151         enddo
3152 !      endif
3153 #endif
3154       if (nfgtasks.gt.1) then
3155         time00=MPI_Wtime()
3156 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3157 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3158 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3159 #ifdef MATGATHER
3160         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3161          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3162          FG_COMM1,IERR)
3163         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3164          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3165          FG_COMM1,IERR)
3166         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3167          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3168          FG_COMM1,IERR)
3169         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3170          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3171          FG_COMM1,IERR)
3172         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3173          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3174          FG_COMM1,IERR)
3175         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3176          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3177          FG_COMM1,IERR)
3178         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3179          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3180          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3181         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3182          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3183          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3184         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3185          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3186          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3187         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3188          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3189          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3190         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3191         then
3192         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3193          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3194          FG_COMM1,IERR)
3195         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3196          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3197          FG_COMM1,IERR)
3198         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3199          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3200          FG_COMM1,IERR)
3201        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3202          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3203          FG_COMM1,IERR)
3204         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3205          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3206          FG_COMM1,IERR)
3207         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3208          ivec_count(fg_rank1),&
3209          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3210          FG_COMM1,IERR)
3211         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3212          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3213          FG_COMM1,IERR)
3214         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3215          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3216          FG_COMM1,IERR)
3217         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3218          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3219          FG_COMM1,IERR)
3220         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3221          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3222          FG_COMM1,IERR)
3223         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3224          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3225          FG_COMM1,IERR)
3226         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3227          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3228          FG_COMM1,IERR)
3229         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3230          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3231          FG_COMM1,IERR)
3232         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3233          ivec_count(fg_rank1),&
3234          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3235          FG_COMM1,IERR)
3236         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3237          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3238          FG_COMM1,IERR)
3239        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3240          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3241          FG_COMM1,IERR)
3242         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3243          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3244          FG_COMM1,IERR)
3245        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3246          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3247          FG_COMM1,IERR)
3248         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3249          ivec_count(fg_rank1),&
3250          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3251          FG_COMM1,IERR)
3252         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3253          ivec_count(fg_rank1),&
3254          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3255          FG_COMM1,IERR)
3256         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3257          ivec_count(fg_rank1),&
3258          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3259          MPI_MAT2,FG_COMM1,IERR)
3260         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3261          ivec_count(fg_rank1),&
3262          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3263          MPI_MAT2,FG_COMM1,IERR)
3264         endif
3265 #else
3266 ! Passes matrix info through the ring
3267       isend=fg_rank1
3268       irecv=fg_rank1-1
3269       if (irecv.lt.0) irecv=nfgtasks1-1
3270       iprev=irecv
3271       inext=fg_rank1+1
3272       if (inext.ge.nfgtasks1) inext=0
3273       do i=1,nfgtasks1-1
3274 !        write (iout,*) "isend",isend," irecv",irecv
3275 !        call flush(iout)
3276         lensend=lentyp(isend)
3277         lenrecv=lentyp(irecv)
3278 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3279 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3280 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3281 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3282 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3283 !        write (iout,*) "Gather ROTAT1"
3284 !        call flush(iout)
3285 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3286 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3287 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3288 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3289 !        write (iout,*) "Gather ROTAT2"
3290 !        call flush(iout)
3291         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3292          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3293          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3294          iprev,4400+irecv,FG_COMM,status,IERR)
3295 !        write (iout,*) "Gather ROTAT_OLD"
3296 !        call flush(iout)
3297         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3298          MPI_PRECOMP11(lensend),inext,5500+isend,&
3299          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3300          iprev,5500+irecv,FG_COMM,status,IERR)
3301 !        write (iout,*) "Gather PRECOMP11"
3302 !        call flush(iout)
3303         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3304          MPI_PRECOMP12(lensend),inext,6600+isend,&
3305          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3306          iprev,6600+irecv,FG_COMM,status,IERR)
3307 !        write (iout,*) "Gather PRECOMP12"
3308 !        call flush(iout)
3309         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3310         then
3311         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3312          MPI_ROTAT2(lensend),inext,7700+isend,&
3313          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3314          iprev,7700+irecv,FG_COMM,status,IERR)
3315 !        write (iout,*) "Gather PRECOMP21"
3316 !        call flush(iout)
3317         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3318          MPI_PRECOMP22(lensend),inext,8800+isend,&
3319          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3320          iprev,8800+irecv,FG_COMM,status,IERR)
3321 !        write (iout,*) "Gather PRECOMP22"
3322 !        call flush(iout)
3323         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3324          MPI_PRECOMP23(lensend),inext,9900+isend,&
3325          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3326          MPI_PRECOMP23(lenrecv),&
3327          iprev,9900+irecv,FG_COMM,status,IERR)
3328 !        write (iout,*) "Gather PRECOMP23"
3329 !        call flush(iout)
3330         endif
3331         isend=irecv
3332         irecv=irecv-1
3333         if (irecv.lt.0) irecv=nfgtasks1-1
3334       enddo
3335 #endif
3336         time_gather=time_gather+MPI_Wtime()-time00
3337       endif
3338 #ifdef DEBUG
3339 !      if (fg_rank.eq.0) then
3340         write (iout,*) "Arrays UG and UGDER"
3341         do i=1,nres-1
3342           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3343            ((ug(l,k,i),l=1,2),k=1,2),&
3344            ((ugder(l,k,i),l=1,2),k=1,2)
3345         enddo
3346         write (iout,*) "Arrays UG2 and UG2DER"
3347         do i=1,nres-1
3348           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3349            ((ug2(l,k,i),l=1,2),k=1,2),&
3350            ((ug2der(l,k,i),l=1,2),k=1,2)
3351         enddo
3352         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3353         do i=1,nres-1
3354           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3355            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3356            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3357         enddo
3358         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3359         do i=1,nres-1
3360           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3361            costab(i),sintab(i),costab2(i),sintab2(i)
3362         enddo
3363         write (iout,*) "Array MUDER"
3364         do i=1,nres-1
3365           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3366         enddo
3367 !      endif
3368 #endif
3369 #endif
3370 !d      do i=1,nres
3371 !d        iti = itortyp(itype(i,1))
3372 !d        write (iout,*) i
3373 !d        do j=1,2
3374 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3375 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3376 !d        enddo
3377 !d      enddo
3378       return
3379       end subroutine set_matrices
3380 !-----------------------------------------------------------------------------
3381       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3382 !
3383 ! This subroutine calculates the average interaction energy and its gradient
3384 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3385 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3386 ! The potential depends both on the distance of peptide-group centers and on
3387 ! the orientation of the CA-CA virtual bonds.
3388 !
3389       use comm_locel
3390 !      implicit real*8 (a-h,o-z)
3391 #ifdef MPI
3392       include 'mpif.h'
3393 #endif
3394 !      include 'DIMENSIONS'
3395 !      include 'COMMON.CONTROL'
3396 !      include 'COMMON.SETUP'
3397 !      include 'COMMON.IOUNITS'
3398 !      include 'COMMON.GEO'
3399 !      include 'COMMON.VAR'
3400 !      include 'COMMON.LOCAL'
3401 !      include 'COMMON.CHAIN'
3402 !      include 'COMMON.DERIV'
3403 !      include 'COMMON.INTERACT'
3404 !      include 'COMMON.CONTACTS'
3405 !      include 'COMMON.TORSION'
3406 !      include 'COMMON.VECTORS'
3407 !      include 'COMMON.FFIELD'
3408 !      include 'COMMON.TIME1'
3409       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3410       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3411       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3412 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3413       real(kind=8),dimension(4) :: muij
3414 !el      integer :: num_conti,j1,j2
3415 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3416 !el        dz_normi,xmedi,ymedi,zmedi
3417
3418 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3419 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3420 !el          num_conti,j1,j2
3421
3422 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3423 #ifdef MOMENT
3424       real(kind=8) :: scal_el=1.0d0
3425 #else
3426       real(kind=8) :: scal_el=0.5d0
3427 #endif
3428 ! 12/13/98
3429 ! 13-go grudnia roku pamietnego...
3430       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3431                                              0.0d0,1.0d0,0.0d0,&
3432                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3433 !el local variables
3434       integer :: i,k,j,icont
3435       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3436       real(kind=8) :: fac,t_eelecij,fracinbuf
3437
3438
3439 !d      write(iout,*) 'In EELEC'
3440 !        print *,"IN EELEC"
3441 !d      do i=1,nloctyp
3442 !d        write(iout,*) 'Type',i
3443 !d        write(iout,*) 'B1',B1(:,i)
3444 !d        write(iout,*) 'B2',B2(:,i)
3445 !d        write(iout,*) 'CC',CC(:,:,i)
3446 !d        write(iout,*) 'DD',DD(:,:,i)
3447 !d        write(iout,*) 'EE',EE(:,:,i)
3448 !d      enddo
3449 !d      call check_vecgrad
3450 !d      stop
3451 !      ees=0.0d0  !AS
3452 !      evdw1=0.0d0
3453 !      eel_loc=0.0d0
3454 !      eello_turn3=0.0d0
3455 !      eello_turn4=0.0d0
3456       t_eelecij=0.0d0
3457       ees=0.0D0
3458       evdw1=0.0D0
3459       eel_loc=0.0d0
3460       eello_turn3=0.0d0
3461       eello_turn4=0.0d0
3462 !
3463
3464       if (icheckgrad.eq.1) then
3465 !el
3466 !        do i=0,2*nres+2
3467 !          dc_norm(1,i)=0.0d0
3468 !          dc_norm(2,i)=0.0d0
3469 !          dc_norm(3,i)=0.0d0
3470 !        enddo
3471         do i=1,nres-1
3472           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3473           do k=1,3
3474             dc_norm(k,i)=dc(k,i)*fac
3475           enddo
3476 !          write (iout,*) 'i',i,' fac',fac
3477         enddo
3478       endif
3479 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3480 !        wturn6
3481       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3482           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3483           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3484 !        call vec_and_deriv
3485 #ifdef TIMING
3486         time01=MPI_Wtime()
3487 #endif
3488 !        print *, "before set matrices"
3489         call set_matrices
3490 !        print *, "after set matrices"
3491
3492 #ifdef TIMING
3493         time_mat=time_mat+MPI_Wtime()-time01
3494 #endif
3495       endif
3496 !       print *, "after set matrices"
3497 !d      do i=1,nres-1
3498 !d        write (iout,*) 'i=',i
3499 !d        do k=1,3
3500 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3501 !d        enddo
3502 !d        do k=1,3
3503 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3504 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3505 !d        enddo
3506 !d      enddo
3507       t_eelecij=0.0d0
3508       ees=0.0D0
3509       evdw1=0.0D0
3510       eel_loc=0.0d0
3511       eello_turn3=0.0d0
3512       eello_turn4=0.0d0
3513 !el      ind=0
3514       do i=1,nres
3515         num_cont_hb(i)=0
3516       enddo
3517 !d      print '(a)','Enter EELEC'
3518 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3519 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3520 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3521       do i=1,nres
3522         gel_loc_loc(i)=0.0d0
3523         gcorr_loc(i)=0.0d0
3524       enddo
3525 !
3526 !
3527 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3528 !
3529 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3530 !
3531
3532
3533 !        print *,"before iturn3 loop"
3534       do i=iturn3_start,iturn3_end
3535         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3536         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3537         dxi=dc(1,i)
3538         dyi=dc(2,i)
3539         dzi=dc(3,i)
3540         dx_normi=dc_norm(1,i)
3541         dy_normi=dc_norm(2,i)
3542         dz_normi=dc_norm(3,i)
3543         xmedi=c(1,i)+0.5d0*dxi
3544         ymedi=c(2,i)+0.5d0*dyi
3545         zmedi=c(3,i)+0.5d0*dzi
3546           xmedi=dmod(xmedi,boxxsize)
3547           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3548           ymedi=dmod(ymedi,boxysize)
3549           if (ymedi.lt.0) ymedi=ymedi+boxysize
3550           zmedi=dmod(zmedi,boxzsize)
3551           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3552         num_conti=0
3553        if ((zmedi.gt.bordlipbot) &
3554         .and.(zmedi.lt.bordliptop)) then
3555 !C the energy transfer exist
3556         if (zmedi.lt.buflipbot) then
3557 !C what fraction I am in
3558          fracinbuf=1.0d0- &
3559                ((zmedi-bordlipbot)/lipbufthick)
3560 !C lipbufthick is thickenes of lipid buffore
3561          sslipi=sscalelip(fracinbuf)
3562          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3563         elseif (zmedi.gt.bufliptop) then
3564          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3565          sslipi=sscalelip(fracinbuf)
3566          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3567         else
3568          sslipi=1.0d0
3569          ssgradlipi=0.0
3570         endif
3571        else
3572          sslipi=0.0d0
3573          ssgradlipi=0.0
3574        endif
3575 !       print *,i,sslipi,ssgradlipi
3576        call eelecij(i,i+2,ees,evdw1,eel_loc)
3577         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3578         num_cont_hb(i)=num_conti
3579       enddo
3580       do i=iturn4_start,iturn4_end
3581         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3582           .or. itype(i+3,1).eq.ntyp1 &
3583           .or. itype(i+4,1).eq.ntyp1) cycle
3584 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3585         dxi=dc(1,i)
3586         dyi=dc(2,i)
3587         dzi=dc(3,i)
3588         dx_normi=dc_norm(1,i)
3589         dy_normi=dc_norm(2,i)
3590         dz_normi=dc_norm(3,i)
3591         xmedi=c(1,i)+0.5d0*dxi
3592         ymedi=c(2,i)+0.5d0*dyi
3593         zmedi=c(3,i)+0.5d0*dzi
3594           xmedi=dmod(xmedi,boxxsize)
3595           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3596           ymedi=dmod(ymedi,boxysize)
3597           if (ymedi.lt.0) ymedi=ymedi+boxysize
3598           zmedi=dmod(zmedi,boxzsize)
3599           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3600        if ((zmedi.gt.bordlipbot)  &
3601        .and.(zmedi.lt.bordliptop)) then
3602 !C the energy transfer exist
3603         if (zmedi.lt.buflipbot) then
3604 !C what fraction I am in
3605          fracinbuf=1.0d0- &
3606              ((zmedi-bordlipbot)/lipbufthick)
3607 !C lipbufthick is thickenes of lipid buffore
3608          sslipi=sscalelip(fracinbuf)
3609          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3610         elseif (zmedi.gt.bufliptop) then
3611          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3612          sslipi=sscalelip(fracinbuf)
3613          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3614         else
3615          sslipi=1.0d0
3616          ssgradlipi=0.0
3617         endif
3618        else
3619          sslipi=0.0d0
3620          ssgradlipi=0.0
3621        endif
3622
3623         num_conti=num_cont_hb(i)
3624         call eelecij(i,i+3,ees,evdw1,eel_loc)
3625         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3626          call eturn4(i,eello_turn4)
3627 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3628         num_cont_hb(i)=num_conti
3629       enddo   ! i
3630 !
3631 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3632 !
3633 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3634 !      do i=iatel_s,iatel_e
3635 ! JPRDLC
3636        do icont=g_listpp_start,g_listpp_end
3637         i=newcontlistppi(icont)
3638         j=newcontlistppj(icont)
3639         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3640         dxi=dc(1,i)
3641         dyi=dc(2,i)
3642         dzi=dc(3,i)
3643         dx_normi=dc_norm(1,i)
3644         dy_normi=dc_norm(2,i)
3645         dz_normi=dc_norm(3,i)
3646         xmedi=c(1,i)+0.5d0*dxi
3647         ymedi=c(2,i)+0.5d0*dyi
3648         zmedi=c(3,i)+0.5d0*dzi
3649           xmedi=dmod(xmedi,boxxsize)
3650           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3651           ymedi=dmod(ymedi,boxysize)
3652           if (ymedi.lt.0) ymedi=ymedi+boxysize
3653           zmedi=dmod(zmedi,boxzsize)
3654           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3655        if ((zmedi.gt.bordlipbot)  &
3656         .and.(zmedi.lt.bordliptop)) then
3657 !C the energy transfer exist
3658         if (zmedi.lt.buflipbot) then
3659 !C what fraction I am in
3660          fracinbuf=1.0d0- &
3661              ((zmedi-bordlipbot)/lipbufthick)
3662 !C lipbufthick is thickenes of lipid buffore
3663          sslipi=sscalelip(fracinbuf)
3664          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3665         elseif (zmedi.gt.bufliptop) then
3666          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3667          sslipi=sscalelip(fracinbuf)
3668          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3669         else
3670          sslipi=1.0d0
3671          ssgradlipi=0.0
3672         endif
3673        else
3674          sslipi=0.0d0
3675          ssgradlipi=0.0
3676        endif
3677
3678 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3679         num_conti=num_cont_hb(i)
3680 !        do j=ielstart(i),ielend(i)
3681 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3682           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3683           call eelecij(i,j,ees,evdw1,eel_loc)
3684 !        enddo ! j
3685         num_cont_hb(i)=num_conti
3686       enddo   ! i
3687 !      write (iout,*) "Number of loop steps in EELEC:",ind
3688 !d      do i=1,nres
3689 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3690 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3691 !d      enddo
3692 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3693 !cc      eel_loc=eel_loc+eello_turn3
3694 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3695       return
3696       end subroutine eelec
3697 !-----------------------------------------------------------------------------
3698       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3699
3700       use comm_locel
3701 !      implicit real*8 (a-h,o-z)
3702 !      include 'DIMENSIONS'
3703 #ifdef MPI
3704       include "mpif.h"
3705 #endif
3706 !      include 'COMMON.CONTROL'
3707 !      include 'COMMON.IOUNITS'
3708 !      include 'COMMON.GEO'
3709 !      include 'COMMON.VAR'
3710 !      include 'COMMON.LOCAL'
3711 !      include 'COMMON.CHAIN'
3712 !      include 'COMMON.DERIV'
3713 !      include 'COMMON.INTERACT'
3714 !      include 'COMMON.CONTACTS'
3715 !      include 'COMMON.TORSION'
3716 !      include 'COMMON.VECTORS'
3717 !      include 'COMMON.FFIELD'
3718 !      include 'COMMON.TIME1'
3719       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3720       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3721       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3722 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3723       real(kind=8),dimension(4) :: muij
3724       real(kind=8) :: geel_loc_ij,geel_loc_ji
3725       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3726                     dist_temp, dist_init,rlocshield,fracinbuf
3727       integer xshift,yshift,zshift,ilist,iresshield
3728 !el      integer :: num_conti,j1,j2
3729 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3730 !el        dz_normi,xmedi,ymedi,zmedi
3731
3732 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3733 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3734 !el          num_conti,j1,j2
3735
3736 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3737 #ifdef MOMENT
3738       real(kind=8) :: scal_el=1.0d0
3739 #else
3740       real(kind=8) :: scal_el=0.5d0
3741 #endif
3742 ! 12/13/98
3743 ! 13-go grudnia roku pamietnego...
3744       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3745                                              0.0d0,1.0d0,0.0d0,&
3746                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3747 !      integer :: maxconts=nres/4
3748 !el local variables
3749       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3750       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3751       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3752       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3753                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3754                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3755                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3756                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3757                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3758                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3759                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3760 !      maxconts=nres/4
3761 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3762 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3763
3764 !          time00=MPI_Wtime()
3765 !d      write (iout,*) "eelecij",i,j
3766 !          ind=ind+1
3767           iteli=itel(i)
3768           itelj=itel(j)
3769           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3770           aaa=app(iteli,itelj)
3771           bbb=bpp(iteli,itelj)
3772           ael6i=ael6(iteli,itelj)
3773           ael3i=ael3(iteli,itelj)
3774           dxj=dc(1,j)
3775           dyj=dc(2,j)
3776           dzj=dc(3,j)
3777           dx_normj=dc_norm(1,j)
3778           dy_normj=dc_norm(2,j)
3779           dz_normj=dc_norm(3,j)
3780 !          xj=c(1,j)+0.5D0*dxj-xmedi
3781 !          yj=c(2,j)+0.5D0*dyj-ymedi
3782 !          zj=c(3,j)+0.5D0*dzj-zmedi
3783           xj=c(1,j)+0.5D0*dxj
3784           yj=c(2,j)+0.5D0*dyj
3785           zj=c(3,j)+0.5D0*dzj
3786           xj=mod(xj,boxxsize)
3787           if (xj.lt.0) xj=xj+boxxsize
3788           yj=mod(yj,boxysize)
3789           if (yj.lt.0) yj=yj+boxysize
3790           zj=mod(zj,boxzsize)
3791           if (zj.lt.0) zj=zj+boxzsize
3792        if ((zj.gt.bordlipbot)  &
3793        .and.(zj.lt.bordliptop)) then
3794 !C the energy transfer exist
3795         if (zj.lt.buflipbot) then
3796 !C what fraction I am in
3797          fracinbuf=1.0d0-     &
3798              ((zj-bordlipbot)/lipbufthick)
3799 !C lipbufthick is thickenes of lipid buffore
3800          sslipj=sscalelip(fracinbuf)
3801          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3802         elseif (zj.gt.bufliptop) then
3803          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3804          sslipj=sscalelip(fracinbuf)
3805          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3806         else
3807          sslipj=1.0d0
3808          ssgradlipj=0.0
3809         endif
3810        else
3811          sslipj=0.0d0
3812          ssgradlipj=0.0
3813        endif
3814
3815       isubchap=0
3816       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3817       xj_safe=xj
3818       yj_safe=yj
3819       zj_safe=zj
3820       do xshift=-1,1
3821       do yshift=-1,1
3822       do zshift=-1,1
3823           xj=xj_safe+xshift*boxxsize
3824           yj=yj_safe+yshift*boxysize
3825           zj=zj_safe+zshift*boxzsize
3826           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3827           if(dist_temp.lt.dist_init) then
3828             dist_init=dist_temp
3829             xj_temp=xj
3830             yj_temp=yj
3831             zj_temp=zj
3832             isubchap=1
3833           endif
3834        enddo
3835        enddo
3836        enddo
3837        if (isubchap.eq.1) then
3838 !C          print *,i,j
3839           xj=xj_temp-xmedi
3840           yj=yj_temp-ymedi
3841           zj=zj_temp-zmedi
3842        else
3843           xj=xj_safe-xmedi
3844           yj=yj_safe-ymedi
3845           zj=zj_safe-zmedi
3846        endif
3847
3848           rij=xj*xj+yj*yj+zj*zj
3849           rrmij=1.0D0/rij
3850           rij=dsqrt(rij)
3851 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3852             sss_ele_cut=sscale_ele(rij)
3853             sss_ele_grad=sscagrad_ele(rij)
3854 !             sss_ele_cut=1.0d0
3855 !             sss_ele_grad=0.0d0
3856 !            print *,sss_ele_cut,sss_ele_grad,&
3857 !            (rij),r_cut_ele,rlamb_ele
3858             if (sss_ele_cut.le.0.0) go to 128
3859
3860           rmij=1.0D0/rij
3861           r3ij=rrmij*rmij
3862           r6ij=r3ij*r3ij
3863           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3864           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3865           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3866           fac=cosa-3.0D0*cosb*cosg
3867           ev1=aaa*r6ij*r6ij
3868 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3869           if (j.eq.i+2) ev1=scal_el*ev1
3870           ev2=bbb*r6ij
3871           fac3=ael6i*r6ij
3872           fac4=ael3i*r3ij
3873           evdwij=ev1+ev2
3874           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3875           el2=fac4*fac
3876 !          eesij=el1+el2
3877           if (shield_mode.gt.0) then
3878 !C          fac_shield(i)=0.4
3879 !C          fac_shield(j)=0.6
3880           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3881           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3882           eesij=(el1+el2)
3883           ees=ees+eesij*sss_ele_cut
3884 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3885 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3886           else
3887           fac_shield(i)=1.0
3888           fac_shield(j)=1.0
3889           eesij=(el1+el2)
3890           ees=ees+eesij   &
3891             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3892 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3893           endif
3894
3895 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3896           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3897 !          ees=ees+eesij*sss_ele_cut
3898           evdw1=evdw1+evdwij*sss_ele_cut  &
3899            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3900 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3901 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3902 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3903 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3904
3905           if (energy_dec) then
3906 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3907 !                  'evdw1',i,j,evdwij,&
3908 !                  iteli,itelj,aaa,evdw1
3909               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3910               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3911           endif
3912 !
3913 ! Calculate contributions to the Cartesian gradient.
3914 !
3915 #ifdef SPLITELE
3916           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3917               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3918           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3919              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3920           fac1=fac
3921           erij(1)=xj*rmij
3922           erij(2)=yj*rmij
3923           erij(3)=zj*rmij
3924 !
3925 ! Radial derivatives. First process both termini of the fragment (i,j)
3926 !
3927           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3928           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3929           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3930            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3931           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3932             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3933
3934           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3935           (shield_mode.gt.0)) then
3936 !C          print *,i,j
3937           do ilist=1,ishield_list(i)
3938            iresshield=shield_list(ilist,i)
3939            do k=1,3
3940            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3941            *2.0*sss_ele_cut
3942            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3943                    rlocshield &
3944             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3945             *sss_ele_cut
3946             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3947            enddo
3948           enddo
3949           do ilist=1,ishield_list(j)
3950            iresshield=shield_list(ilist,j)
3951            do k=1,3
3952            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3953           *2.0*sss_ele_cut
3954            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3955                    rlocshield &
3956            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3957            *sss_ele_cut
3958            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3959            enddo
3960           enddo
3961           do k=1,3
3962             gshieldc(k,i)=gshieldc(k,i)+ &
3963                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3964            *sss_ele_cut
3965
3966             gshieldc(k,j)=gshieldc(k,j)+ &
3967                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3968            *sss_ele_cut
3969
3970             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3971                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3972            *sss_ele_cut
3973
3974             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3975                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3976            *sss_ele_cut
3977
3978            enddo
3979            endif
3980
3981
3982 !          do k=1,3
3983 !            ghalf=0.5D0*ggg(k)
3984 !            gelc(k,i)=gelc(k,i)+ghalf
3985 !            gelc(k,j)=gelc(k,j)+ghalf
3986 !          enddo
3987 ! 9/28/08 AL Gradient compotents will be summed only at the end
3988           do k=1,3
3989             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3990             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3991           enddo
3992             gelc_long(3,j)=gelc_long(3,j)+  &
3993           ssgradlipj*eesij/2.0d0*lipscale**2&
3994            *sss_ele_cut
3995
3996             gelc_long(3,i)=gelc_long(3,i)+  &
3997           ssgradlipi*eesij/2.0d0*lipscale**2&
3998            *sss_ele_cut
3999
4000
4001 !
4002 ! Loop over residues i+1 thru j-1.
4003 !
4004 !grad          do k=i+1,j-1
4005 !grad            do l=1,3
4006 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4007 !grad            enddo
4008 !grad          enddo
4009           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
4010            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4011           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
4012            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4013           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
4014            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4015
4016 !          do k=1,3
4017 !            ghalf=0.5D0*ggg(k)
4018 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4019 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4020 !          enddo
4021 ! 9/28/08 AL Gradient compotents will be summed only at the end
4022           do k=1,3
4023             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4024             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4025           enddo
4026
4027 !C Lipidic part for scaling weight
4028            gvdwpp(3,j)=gvdwpp(3,j)+ &
4029           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4030            gvdwpp(3,i)=gvdwpp(3,i)+ &
4031           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4032 !! Loop over residues i+1 thru j-1.
4033 !
4034 !grad          do k=i+1,j-1
4035 !grad            do l=1,3
4036 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4037 !grad            enddo
4038 !grad          enddo
4039 #else
4040           facvdw=(ev1+evdwij)*sss_ele_cut &
4041            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4042
4043           facel=(el1+eesij)*sss_ele_cut
4044           fac1=fac
4045           fac=-3*rrmij*(facvdw+facvdw+facel)
4046           erij(1)=xj*rmij
4047           erij(2)=yj*rmij
4048           erij(3)=zj*rmij
4049 !
4050 ! Radial derivatives. First process both termini of the fragment (i,j)
4051 !
4052           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
4053           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
4054           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
4055 !          do k=1,3
4056 !            ghalf=0.5D0*ggg(k)
4057 !            gelc(k,i)=gelc(k,i)+ghalf
4058 !            gelc(k,j)=gelc(k,j)+ghalf
4059 !          enddo
4060 ! 9/28/08 AL Gradient compotents will be summed only at the end
4061           do k=1,3
4062             gelc_long(k,j)=gelc(k,j)+ggg(k)
4063             gelc_long(k,i)=gelc(k,i)-ggg(k)
4064           enddo
4065 !
4066 ! Loop over residues i+1 thru j-1.
4067 !
4068 !grad          do k=i+1,j-1
4069 !grad            do l=1,3
4070 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4071 !grad            enddo
4072 !grad          enddo
4073 ! 9/28/08 AL Gradient compotents will be summed only at the end
4074           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
4075            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4076           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
4077            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4078           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
4079            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4080
4081           do k=1,3
4082             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4083             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4084           enddo
4085            gvdwpp(3,j)=gvdwpp(3,j)+ &
4086           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
4087            gvdwpp(3,i)=gvdwpp(3,i)+ &
4088           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
4089
4090 #endif
4091 !
4092 ! Angular part
4093 !
4094           ecosa=2.0D0*fac3*fac1+fac4
4095           fac4=-3.0D0*fac4
4096           fac3=-6.0D0*fac3
4097           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4098           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4099           do k=1,3
4100             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4101             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4102           enddo
4103 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4104 !d   &          (dcosg(k),k=1,3)
4105           do k=1,3
4106             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
4107              *fac_shield(i)**2*fac_shield(j)**2 &
4108              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4109
4110           enddo
4111 !          do k=1,3
4112 !            ghalf=0.5D0*ggg(k)
4113 !            gelc(k,i)=gelc(k,i)+ghalf
4114 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4115 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4116 !            gelc(k,j)=gelc(k,j)+ghalf
4117 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4118 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4119 !          enddo
4120 !grad          do k=i+1,j-1
4121 !grad            do l=1,3
4122 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4123 !grad            enddo
4124 !grad          enddo
4125           do k=1,3
4126             gelc(k,i)=gelc(k,i) &
4127                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4128                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4129                      *sss_ele_cut &
4130                      *fac_shield(i)**2*fac_shield(j)**2 &
4131                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4132
4133             gelc(k,j)=gelc(k,j) &
4134                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4135                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4136                      *sss_ele_cut  &
4137                      *fac_shield(i)**2*fac_shield(j)**2  &
4138                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4139
4140             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4141             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4142           enddo
4143
4144           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4145               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4146               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4147 !
4148 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4149 !   energy of a peptide unit is assumed in the form of a second-order
4150 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4151 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4152 !   are computed for EVERY pair of non-contiguous peptide groups.
4153 !
4154           if (j.lt.nres-1) then
4155             j1=j+1
4156             j2=j-1
4157           else
4158             j1=j-1
4159             j2=j-2
4160           endif
4161           kkk=0
4162           do k=1,2
4163             do l=1,2
4164               kkk=kkk+1
4165               muij(kkk)=mu(k,i)*mu(l,j)
4166 #ifdef NEWCORR
4167              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4168 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4169              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4170              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4171 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4172              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4173 #endif
4174
4175             enddo
4176           enddo
4177 !d         write (iout,*) 'EELEC: i',i,' j',j
4178 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4179 !d          write(iout,*) 'muij',muij
4180           ury=scalar(uy(1,i),erij)
4181           urz=scalar(uz(1,i),erij)
4182           vry=scalar(uy(1,j),erij)
4183           vrz=scalar(uz(1,j),erij)
4184           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4185           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4186           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4187           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4188           fac=dsqrt(-ael6i)*r3ij
4189           a22=a22*fac
4190           a23=a23*fac
4191           a32=a32*fac
4192           a33=a33*fac
4193 !d          write (iout,'(4i5,4f10.5)')
4194 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4195 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4196 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4197 !d     &      uy(:,j),uz(:,j)
4198 !d          write (iout,'(4f10.5)')
4199 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4200 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4201 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4202 !d           write (iout,'(9f10.5/)')
4203 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4204 ! Derivatives of the elements of A in virtual-bond vectors
4205           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4206           do k=1,3
4207             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4208             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4209             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4210             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4211             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4212             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4213             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4214             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4215             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4216             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4217             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4218             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4219           enddo
4220 ! Compute radial contributions to the gradient
4221           facr=-3.0d0*rrmij
4222           a22der=a22*facr
4223           a23der=a23*facr
4224           a32der=a32*facr
4225           a33der=a33*facr
4226           agg(1,1)=a22der*xj
4227           agg(2,1)=a22der*yj
4228           agg(3,1)=a22der*zj
4229           agg(1,2)=a23der*xj
4230           agg(2,2)=a23der*yj
4231           agg(3,2)=a23der*zj
4232           agg(1,3)=a32der*xj
4233           agg(2,3)=a32der*yj
4234           agg(3,3)=a32der*zj
4235           agg(1,4)=a33der*xj
4236           agg(2,4)=a33der*yj
4237           agg(3,4)=a33der*zj
4238 ! Add the contributions coming from er
4239           fac3=-3.0d0*fac
4240           do k=1,3
4241             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4242             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4243             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4244             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4245           enddo
4246           do k=1,3
4247 ! Derivatives in DC(i)
4248 !grad            ghalf1=0.5d0*agg(k,1)
4249 !grad            ghalf2=0.5d0*agg(k,2)
4250 !grad            ghalf3=0.5d0*agg(k,3)
4251 !grad            ghalf4=0.5d0*agg(k,4)
4252             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4253             -3.0d0*uryg(k,2)*vry)!+ghalf1
4254             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4255             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4256             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4257             -3.0d0*urzg(k,2)*vry)!+ghalf3
4258             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4259             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4260 ! Derivatives in DC(i+1)
4261             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4262             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4263             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4264             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4265             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4266             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4267             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4268             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4269 ! Derivatives in DC(j)
4270             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4271             -3.0d0*vryg(k,2)*ury)!+ghalf1
4272             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4273             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4274             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4275             -3.0d0*vryg(k,2)*urz)!+ghalf3
4276             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4277             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4278 ! Derivatives in DC(j+1) or DC(nres-1)
4279             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4280             -3.0d0*vryg(k,3)*ury)
4281             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4282             -3.0d0*vrzg(k,3)*ury)
4283             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4284             -3.0d0*vryg(k,3)*urz)
4285             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4286             -3.0d0*vrzg(k,3)*urz)
4287 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4288 !grad              do l=1,4
4289 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4290 !grad              enddo
4291 !grad            endif
4292           enddo
4293           acipa(1,1)=a22
4294           acipa(1,2)=a23
4295           acipa(2,1)=a32
4296           acipa(2,2)=a33
4297           a22=-a22
4298           a23=-a23
4299           do l=1,2
4300             do k=1,3
4301               agg(k,l)=-agg(k,l)
4302               aggi(k,l)=-aggi(k,l)
4303               aggi1(k,l)=-aggi1(k,l)
4304               aggj(k,l)=-aggj(k,l)
4305               aggj1(k,l)=-aggj1(k,l)
4306             enddo
4307           enddo
4308           if (j.lt.nres-1) then
4309             a22=-a22
4310             a32=-a32
4311             do l=1,3,2
4312               do k=1,3
4313                 agg(k,l)=-agg(k,l)
4314                 aggi(k,l)=-aggi(k,l)
4315                 aggi1(k,l)=-aggi1(k,l)
4316                 aggj(k,l)=-aggj(k,l)
4317                 aggj1(k,l)=-aggj1(k,l)
4318               enddo
4319             enddo
4320           else
4321             a22=-a22
4322             a23=-a23
4323             a32=-a32
4324             a33=-a33
4325             do l=1,4
4326               do k=1,3
4327                 agg(k,l)=-agg(k,l)
4328                 aggi(k,l)=-aggi(k,l)
4329                 aggi1(k,l)=-aggi1(k,l)
4330                 aggj(k,l)=-aggj(k,l)
4331                 aggj1(k,l)=-aggj1(k,l)
4332               enddo
4333             enddo
4334           endif
4335           ENDIF ! WCORR
4336           IF (wel_loc.gt.0.0d0) THEN
4337 ! Contribution to the local-electrostatic energy coming from the i-j pair
4338           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4339            +a33*muij(4)
4340           if (shield_mode.eq.0) then
4341            fac_shield(i)=1.0
4342            fac_shield(j)=1.0
4343           endif
4344           eel_loc_ij=eel_loc_ij &
4345          *fac_shield(i)*fac_shield(j) &
4346          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4347 !C Now derivative over eel_loc
4348           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4349          (shield_mode.gt.0)) then
4350 !C          print *,i,j
4351
4352           do ilist=1,ishield_list(i)
4353            iresshield=shield_list(ilist,i)
4354            do k=1,3
4355            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4356                                                 /fac_shield(i)&
4357            *sss_ele_cut
4358            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4359                    rlocshield  &
4360           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4361           *sss_ele_cut
4362
4363             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4364            +rlocshield
4365            enddo
4366           enddo
4367           do ilist=1,ishield_list(j)
4368            iresshield=shield_list(ilist,j)
4369            do k=1,3
4370            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4371                                             /fac_shield(j)   &
4372             *sss_ele_cut
4373            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4374                    rlocshield  &
4375       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4376        *sss_ele_cut
4377
4378            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4379                   +rlocshield
4380
4381            enddo
4382           enddo
4383
4384           do k=1,3
4385             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4386                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4387                     *sss_ele_cut
4388             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4389                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4390                     *sss_ele_cut
4391             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4392                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4393                     *sss_ele_cut
4394             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4395                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4396                     *sss_ele_cut
4397
4398            enddo
4399            endif
4400
4401 #ifdef NEWCORR
4402          geel_loc_ij=(a22*gmuij1(1)&
4403           +a23*gmuij1(2)&
4404           +a32*gmuij1(3)&
4405           +a33*gmuij1(4))&
4406          *fac_shield(i)*fac_shield(j)&
4407                     *sss_ele_cut     &
4408          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4409
4410
4411 !c         write(iout,*) "derivative over thatai"
4412 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4413 !c     &   a33*gmuij1(4)
4414          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4415            geel_loc_ij*wel_loc
4416 !c         write(iout,*) "derivative over thatai-1"
4417 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4418 !c     &   a33*gmuij2(4)
4419          geel_loc_ij=&
4420           a22*gmuij2(1)&
4421           +a23*gmuij2(2)&
4422           +a32*gmuij2(3)&
4423           +a33*gmuij2(4)
4424          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4425            geel_loc_ij*wel_loc&
4426          *fac_shield(i)*fac_shield(j)&
4427                     *sss_ele_cut &
4428          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4429
4430
4431 !c  Derivative over j residue
4432          geel_loc_ji=a22*gmuji1(1)&
4433           +a23*gmuji1(2)&
4434           +a32*gmuji1(3)&
4435           +a33*gmuji1(4)
4436 !c         write(iout,*) "derivative over thataj"
4437 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4438 !c     &   a33*gmuji1(4)
4439
4440         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4441            geel_loc_ji*wel_loc&
4442          *fac_shield(i)*fac_shield(j)&
4443                     *sss_ele_cut &
4444          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4445
4446
4447          geel_loc_ji=&
4448           +a22*gmuji2(1)&
4449           +a23*gmuji2(2)&
4450           +a32*gmuji2(3)&
4451           +a33*gmuji2(4)
4452 !c         write(iout,*) "derivative over thataj-1"
4453 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4454 !c     &   a33*gmuji2(4)
4455          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4456            geel_loc_ji*wel_loc&
4457          *fac_shield(i)*fac_shield(j)&
4458                     *sss_ele_cut &
4459          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4460
4461 #endif
4462
4463 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4464 !           eel_loc_ij=0.0
4465 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4466 !                  'eelloc',i,j,eel_loc_ij
4467           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4468                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4469 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4470
4471 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4472 !          if (energy_dec) write (iout,*) "muij",muij
4473 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4474
4475           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4476 ! Partial derivatives in virtual-bond dihedral angles gamma
4477           if (i.gt.1) &
4478           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4479                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4480                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4481                  *sss_ele_cut  &
4482           *fac_shield(i)*fac_shield(j) &
4483           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4484
4485           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4486                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4487                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4488                  *sss_ele_cut &
4489           *fac_shield(i)*fac_shield(j) &
4490           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4491 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4492 !          do l=1,3
4493 !            ggg(1)=(agg(1,1)*muij(1)+ &
4494 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4495 !            *sss_ele_cut &
4496 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4497 !            ggg(2)=(agg(2,1)*muij(1)+ &
4498 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4499 !            *sss_ele_cut &
4500 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4501 !            ggg(3)=(agg(3,1)*muij(1)+ &
4502 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4503 !            *sss_ele_cut &
4504 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4505            xtemp(1)=xj
4506            xtemp(2)=yj
4507            xtemp(3)=zj
4508
4509            do l=1,3
4510             ggg(l)=(agg(l,1)*muij(1)+ &
4511                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4512             *sss_ele_cut &
4513           *fac_shield(i)*fac_shield(j) &
4514           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4515              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4516
4517
4518             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4519             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4520 !grad            ghalf=0.5d0*ggg(l)
4521 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4522 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4523           enddo
4524             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4525           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4526           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4527
4528             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4529           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4530           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4531
4532 !grad          do k=i+1,j2
4533 !grad            do l=1,3
4534 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4535 !grad            enddo
4536 !grad          enddo
4537 ! Remaining derivatives of eello
4538           do l=1,3
4539             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4540                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4541             *sss_ele_cut &
4542           *fac_shield(i)*fac_shield(j) &
4543           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4544
4545 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4546             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4547                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4548             +aggi1(l,4)*muij(4))&
4549             *sss_ele_cut &
4550           *fac_shield(i)*fac_shield(j) &
4551           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4552
4553 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4554             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4555                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4556             *sss_ele_cut &
4557           *fac_shield(i)*fac_shield(j) &
4558           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4559
4560 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4561             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4562                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4563             +aggj1(l,4)*muij(4))&
4564             *sss_ele_cut &
4565           *fac_shield(i)*fac_shield(j) &
4566          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4567
4568 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4569           enddo
4570           ENDIF
4571 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4572 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4573           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4574              .and. num_conti.le.maxconts) then
4575 !            write (iout,*) i,j," entered corr"
4576 !
4577 ! Calculate the contact function. The ith column of the array JCONT will
4578 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4579 ! greater than I). The arrays FACONT and GACONT will contain the values of
4580 ! the contact function and its derivative.
4581 !           r0ij=1.02D0*rpp(iteli,itelj)
4582 !           r0ij=1.11D0*rpp(iteli,itelj)
4583             r0ij=2.20D0*rpp(iteli,itelj)
4584 !           r0ij=1.55D0*rpp(iteli,itelj)
4585             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4586 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4587             if (fcont.gt.0.0D0) then
4588               num_conti=num_conti+1
4589               if (num_conti.gt.maxconts) then
4590 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4591 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4592                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4593                                ' will skip next contacts for this conf.', num_conti
4594               else
4595                 jcont_hb(num_conti,i)=j
4596 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4597 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4598                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4599                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4600 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4601 !  terms.
4602                 d_cont(num_conti,i)=rij
4603 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4604 !     --- Electrostatic-interaction matrix ---
4605                 a_chuj(1,1,num_conti,i)=a22
4606                 a_chuj(1,2,num_conti,i)=a23
4607                 a_chuj(2,1,num_conti,i)=a32
4608                 a_chuj(2,2,num_conti,i)=a33
4609 !     --- Gradient of rij
4610                 do kkk=1,3
4611                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4612                 enddo
4613                 kkll=0
4614                 do k=1,2
4615                   do l=1,2
4616                     kkll=kkll+1
4617                     do m=1,3
4618                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4619                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4620                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4621                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4622                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4623                     enddo
4624                   enddo
4625                 enddo
4626                 ENDIF
4627                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4628 ! Calculate contact energies
4629                 cosa4=4.0D0*cosa
4630                 wij=cosa-3.0D0*cosb*cosg
4631                 cosbg1=cosb+cosg
4632                 cosbg2=cosb-cosg
4633 !               fac3=dsqrt(-ael6i)/r0ij**3
4634                 fac3=dsqrt(-ael6i)*r3ij
4635 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4636                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4637                 if (ees0tmp.gt.0) then
4638                   ees0pij=dsqrt(ees0tmp)
4639                 else
4640                   ees0pij=0
4641                 endif
4642                 if (shield_mode.eq.0) then
4643                 fac_shield(i)=1.0d0
4644                 fac_shield(j)=1.0d0
4645                 else
4646                 ees0plist(num_conti,i)=j
4647                 endif
4648 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4649                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4650                 if (ees0tmp.gt.0) then
4651                   ees0mij=dsqrt(ees0tmp)
4652                 else
4653                   ees0mij=0
4654                 endif
4655 !               ees0mij=0.0D0
4656                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4657                      *sss_ele_cut &
4658                      *fac_shield(i)*fac_shield(j)
4659 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4660
4661                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4662                      *sss_ele_cut &
4663                      *fac_shield(i)*fac_shield(j)
4664 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4665
4666 ! Diagnostics. Comment out or remove after debugging!
4667 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4668 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4669 !               ees0m(num_conti,i)=0.0D0
4670 ! End diagnostics.
4671 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4672 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4673 ! Angular derivatives of the contact function
4674                 ees0pij1=fac3/ees0pij
4675                 ees0mij1=fac3/ees0mij
4676                 fac3p=-3.0D0*fac3*rrmij
4677                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4678                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4679 !               ees0mij1=0.0D0
4680                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4681                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4682                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4683                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4684                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4685                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4686                 ecosap=ecosa1+ecosa2
4687                 ecosbp=ecosb1+ecosb2
4688                 ecosgp=ecosg1+ecosg2
4689                 ecosam=ecosa1-ecosa2
4690                 ecosbm=ecosb1-ecosb2
4691                 ecosgm=ecosg1-ecosg2
4692 ! Diagnostics
4693 !               ecosap=ecosa1
4694 !               ecosbp=ecosb1
4695 !               ecosgp=ecosg1
4696 !               ecosam=0.0D0
4697 !               ecosbm=0.0D0
4698 !               ecosgm=0.0D0
4699 ! End diagnostics
4700                 facont_hb(num_conti,i)=fcont
4701                 fprimcont=fprimcont/rij
4702 !d              facont_hb(num_conti,i)=1.0D0
4703 ! Following line is for diagnostics.
4704 !d              fprimcont=0.0D0
4705                 do k=1,3
4706                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4707                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4708                 enddo
4709                 do k=1,3
4710                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4711                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4712                 enddo
4713                 gggp(1)=gggp(1)+ees0pijp*xj &
4714                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4715                 gggp(2)=gggp(2)+ees0pijp*yj &
4716                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4717                 gggp(3)=gggp(3)+ees0pijp*zj &
4718                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4719
4720                 gggm(1)=gggm(1)+ees0mijp*xj &
4721                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4722
4723                 gggm(2)=gggm(2)+ees0mijp*yj &
4724                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4725
4726                 gggm(3)=gggm(3)+ees0mijp*zj &
4727                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4728
4729 ! Derivatives due to the contact function
4730                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4731                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4732                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4733                 do k=1,3
4734 !
4735 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4736 !          following the change of gradient-summation algorithm.
4737 !
4738 !grad                  ghalfp=0.5D0*gggp(k)
4739 !grad                  ghalfm=0.5D0*gggm(k)
4740                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4741                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4742                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4743                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4744 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4745
4746
4747                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4748                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4749                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4750                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4751 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4752
4753
4754                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4755                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4756 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4757
4758                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4759                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4760                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4761                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4762 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4763
4764                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4765                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4766                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4767                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4768 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4769
4770                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4771                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4772 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4773
4774                 enddo
4775 ! Diagnostics. Comment out or remove after debugging!
4776 !diag           do k=1,3
4777 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4778 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4779 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4780 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4781 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4782 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4783 !diag           enddo
4784               ENDIF ! wcorr
4785               endif  ! num_conti.le.maxconts
4786             endif  ! fcont.gt.0
4787           endif    ! j.gt.i+1
4788           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4789             do k=1,4
4790               do l=1,3
4791                 ghalf=0.5d0*agg(l,k)
4792                 aggi(l,k)=aggi(l,k)+ghalf
4793                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4794                 aggj(l,k)=aggj(l,k)+ghalf
4795               enddo
4796             enddo
4797             if (j.eq.nres-1 .and. i.lt.j-2) then
4798               do k=1,4
4799                 do l=1,3
4800                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4801                 enddo
4802               enddo
4803             endif
4804           endif
4805  128  continue
4806 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4807       return
4808       end subroutine eelecij
4809 !-----------------------------------------------------------------------------
4810       subroutine eturn3(i,eello_turn3)
4811 ! Third- and fourth-order contributions from turns
4812
4813       use comm_locel
4814 !      implicit real*8 (a-h,o-z)
4815 !      include 'DIMENSIONS'
4816 !      include 'COMMON.IOUNITS'
4817 !      include 'COMMON.GEO'
4818 !      include 'COMMON.VAR'
4819 !      include 'COMMON.LOCAL'
4820 !      include 'COMMON.CHAIN'
4821 !      include 'COMMON.DERIV'
4822 !      include 'COMMON.INTERACT'
4823 !      include 'COMMON.CONTACTS'
4824 !      include 'COMMON.TORSION'
4825 !      include 'COMMON.VECTORS'
4826 !      include 'COMMON.FFIELD'
4827 !      include 'COMMON.CONTROL'
4828       real(kind=8),dimension(3) :: ggg
4829       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4830         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4831        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4832
4833       real(kind=8),dimension(2) :: auxvec,auxvec1
4834 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4835       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4836 !el      integer :: num_conti,j1,j2
4837 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4838 !el        dz_normi,xmedi,ymedi,zmedi
4839
4840 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4841 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4842 !el         num_conti,j1,j2
4843 !el local variables
4844       integer :: i,j,l,k,ilist,iresshield
4845       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4846
4847       j=i+2
4848 !      write (iout,*) "eturn3",i,j,j1,j2
4849           zj=(c(3,j)+c(3,j+1))/2.0d0
4850           zj=mod(zj,boxzsize)
4851           if (zj.lt.0) zj=zj+boxzsize
4852           if ((zj.lt.0)) write (*,*) "CHUJ"
4853        if ((zj.gt.bordlipbot)  &
4854         .and.(zj.lt.bordliptop)) then
4855 !C the energy transfer exist
4856         if (zj.lt.buflipbot) then
4857 !C what fraction I am in
4858          fracinbuf=1.0d0-     &
4859              ((zj-bordlipbot)/lipbufthick)
4860 !C lipbufthick is thickenes of lipid buffore
4861          sslipj=sscalelip(fracinbuf)
4862          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4863         elseif (zj.gt.bufliptop) then
4864          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4865          sslipj=sscalelip(fracinbuf)
4866          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4867         else
4868          sslipj=1.0d0
4869          ssgradlipj=0.0
4870         endif
4871        else
4872          sslipj=0.0d0
4873          ssgradlipj=0.0
4874        endif
4875
4876       a_temp(1,1)=a22
4877       a_temp(1,2)=a23
4878       a_temp(2,1)=a32
4879       a_temp(2,2)=a33
4880 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4881 !
4882 !               Third-order contributions
4883 !
4884 !                 (i+2)o----(i+3)
4885 !                      | |
4886 !                      | |
4887 !                 (i+1)o----i
4888 !
4889 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4890 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4891         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4892         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4893         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4894         call transpose2(auxmat(1,1),auxmat1(1,1))
4895         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4896         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4897         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4898         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4899         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4900
4901         if (shield_mode.eq.0) then
4902         fac_shield(i)=1.0d0
4903         fac_shield(j)=1.0d0
4904         endif
4905
4906         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4907          *fac_shield(i)*fac_shield(j)  &
4908          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4909         eello_t3= &
4910         0.5d0*(pizda(1,1)+pizda(2,2)) &
4911         *fac_shield(i)*fac_shield(j)
4912
4913         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4914                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4915 !C#ifdef NEWCORR
4916 !C Derivatives in theta
4917         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4918        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4919         *fac_shield(i)*fac_shield(j) &
4920         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4921
4922         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4923        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4924         *fac_shield(i)*fac_shield(j) &
4925         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4926
4927
4928 !C#endif
4929
4930
4931
4932           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4933        (shield_mode.gt.0)) then
4934 !C          print *,i,j
4935
4936           do ilist=1,ishield_list(i)
4937            iresshield=shield_list(ilist,i)
4938            do k=1,3
4939            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4940            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4941                    rlocshield &
4942            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4943             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4944              +rlocshield
4945            enddo
4946           enddo
4947           do ilist=1,ishield_list(j)
4948            iresshield=shield_list(ilist,j)
4949            do k=1,3
4950            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4951            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4952                    rlocshield &
4953            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4954            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4955                   +rlocshield
4956
4957            enddo
4958           enddo
4959
4960           do k=1,3
4961             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4962                    grad_shield(k,i)*eello_t3/fac_shield(i)
4963             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4964                    grad_shield(k,j)*eello_t3/fac_shield(j)
4965             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4966                    grad_shield(k,i)*eello_t3/fac_shield(i)
4967             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4968                    grad_shield(k,j)*eello_t3/fac_shield(j)
4969            enddo
4970            endif
4971
4972 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4973 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4974 !d     &    ' eello_turn3_num',4*eello_turn3_num
4975 ! Derivatives in gamma(i)
4976         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4977         call transpose2(auxmat2(1,1),auxmat3(1,1))
4978         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4979         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4980           *fac_shield(i)*fac_shield(j)        &
4981           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4982 ! Derivatives in gamma(i+1)
4983         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4984         call transpose2(auxmat2(1,1),auxmat3(1,1))
4985         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4986         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4987           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4988           *fac_shield(i)*fac_shield(j)        &
4989           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4990
4991 ! Cartesian derivatives
4992         do l=1,3
4993 !            ghalf1=0.5d0*agg(l,1)
4994 !            ghalf2=0.5d0*agg(l,2)
4995 !            ghalf3=0.5d0*agg(l,3)
4996 !            ghalf4=0.5d0*agg(l,4)
4997           a_temp(1,1)=aggi(l,1)!+ghalf1
4998           a_temp(1,2)=aggi(l,2)!+ghalf2
4999           a_temp(2,1)=aggi(l,3)!+ghalf3
5000           a_temp(2,2)=aggi(l,4)!+ghalf4
5001           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5002           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
5003             +0.5d0*(pizda(1,1)+pizda(2,2))  &
5004           *fac_shield(i)*fac_shield(j)      &
5005           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5006
5007           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5008           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5009           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5010           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5011           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5012           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
5013             +0.5d0*(pizda(1,1)+pizda(2,2))    &
5014           *fac_shield(i)*fac_shield(j)        &
5015           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5016
5017           a_temp(1,1)=aggj(l,1)!+ghalf1
5018           a_temp(1,2)=aggj(l,2)!+ghalf2
5019           a_temp(2,1)=aggj(l,3)!+ghalf3
5020           a_temp(2,2)=aggj(l,4)!+ghalf4
5021           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5022           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
5023             +0.5d0*(pizda(1,1)+pizda(2,2))  &
5024           *fac_shield(i)*fac_shield(j)      &
5025           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5026
5027           a_temp(1,1)=aggj1(l,1)
5028           a_temp(1,2)=aggj1(l,2)
5029           a_temp(2,1)=aggj1(l,3)
5030           a_temp(2,2)=aggj1(l,4)
5031           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5032           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
5033             +0.5d0*(pizda(1,1)+pizda(2,2))    &
5034           *fac_shield(i)*fac_shield(j)        &
5035           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5036         enddo
5037          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
5038           ssgradlipi*eello_t3/4.0d0*lipscale
5039          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
5040           ssgradlipj*eello_t3/4.0d0*lipscale
5041          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
5042           ssgradlipi*eello_t3/4.0d0*lipscale
5043          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
5044           ssgradlipj*eello_t3/4.0d0*lipscale
5045
5046       return
5047       end subroutine eturn3
5048 !-----------------------------------------------------------------------------
5049       subroutine eturn4(i,eello_turn4)
5050 ! Third- and fourth-order contributions from turns
5051
5052       use comm_locel
5053 !      implicit real*8 (a-h,o-z)
5054 !      include 'DIMENSIONS'
5055 !      include 'COMMON.IOUNITS'
5056 !      include 'COMMON.GEO'
5057 !      include 'COMMON.VAR'
5058 !      include 'COMMON.LOCAL'
5059 !      include 'COMMON.CHAIN'
5060 !      include 'COMMON.DERIV'
5061 !      include 'COMMON.INTERACT'
5062 !      include 'COMMON.CONTACTS'
5063 !      include 'COMMON.TORSION'
5064 !      include 'COMMON.VECTORS'
5065 !      include 'COMMON.FFIELD'
5066 !      include 'COMMON.CONTROL'
5067       real(kind=8),dimension(3) :: ggg
5068       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
5069         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
5070         gte1t,gte2t,gte3t,&
5071         gte1a,gtae3,gtae3e2, ae3gte2,&
5072         gtEpizda1,gtEpizda2,gtEpizda3
5073
5074       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
5075        auxgEvec3,auxgvec
5076
5077 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
5078       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
5079 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
5080 !el        dz_normi,xmedi,ymedi,zmedi
5081 !el      integer :: num_conti,j1,j2
5082 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
5083 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
5084 !el          num_conti,j1,j2
5085 !el local variables
5086       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
5087       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
5088          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3
5089
5090       j=i+3
5091 !      if (j.ne.20) return
5092 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
5093 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5094 !
5095 !               Fourth-order contributions
5096 !
5097 !                 (i+3)o----(i+4)
5098 !                     /  |
5099 !               (i+2)o   |
5100 !                     \  |
5101 !                 (i+1)o----i
5102 !
5103 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5104 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
5105 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5106           zj=(c(3,j)+c(3,j+1))/2.0d0
5107           zj=mod(zj,boxzsize)
5108           if (zj.lt.0) zj=zj+boxzsize
5109        if ((zj.gt.bordlipbot)  &
5110         .and.(zj.lt.bordliptop)) then
5111 !C the energy transfer exist
5112         if (zj.lt.buflipbot) then
5113 !C what fraction I am in
5114          fracinbuf=1.0d0-     &
5115              ((zj-bordlipbot)/lipbufthick)
5116 !C lipbufthick is thickenes of lipid buffore
5117          sslipj=sscalelip(fracinbuf)
5118          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5119         elseif (zj.gt.bufliptop) then
5120          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5121          sslipj=sscalelip(fracinbuf)
5122          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5123         else
5124          sslipj=1.0d0
5125          ssgradlipj=0.0
5126         endif
5127        else
5128          sslipj=0.0d0
5129          ssgradlipj=0.0
5130        endif
5131
5132         a_temp(1,1)=a22
5133         a_temp(1,2)=a23
5134         a_temp(2,1)=a32
5135         a_temp(2,2)=a33
5136         iti1=i+1
5137         iti2=i+2
5138         iti3=i+3
5139 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5140         call transpose2(EUg(1,1,i+1),e1t(1,1))
5141         call transpose2(Eug(1,1,i+2),e2t(1,1))
5142         call transpose2(Eug(1,1,i+3),e3t(1,1))
5143 !C Ematrix derivative in theta
5144         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5145         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5146         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5147
5148         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5149         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5150         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5151         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5152 !c       auxalary matrix of E i+1
5153         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5154         s1=scalar2(b1(1,iti2),auxvec(1))
5155 !c derivative of theta i+2 with constant i+3
5156         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5157 !c derivative of theta i+2 with constant i+2
5158         gs32=scalar2(b1(1,i+2),auxgvec(1))
5159 !c derivative of E matix in theta of i+1
5160         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5161
5162         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5163         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5164         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5165 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5166         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5167 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5168         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5169         s2=scalar2(b1(1,i+1),auxvec(1))
5170 !c derivative of theta i+1 with constant i+3
5171         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5172 !c derivative of theta i+2 with constant i+1
5173         gs21=scalar2(b1(1,i+1),auxgvec(1))
5174 !c derivative of theta i+3 with constant i+1
5175         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5176
5177         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5178         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5179 !c ae3gte2 is derivative over i+2
5180         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5181
5182         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5183         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5184 !c i+2
5185         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5186 !c i+3
5187         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5188
5189         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5190         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5191         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5192         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5193         if (shield_mode.eq.0) then
5194         fac_shield(i)=1.0
5195         fac_shield(j)=1.0
5196         endif
5197
5198         eello_turn4=eello_turn4-(s1+s2+s3) &
5199         *fac_shield(i)*fac_shield(j)       &
5200         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5201         eello_t4=-(s1+s2+s3)  &
5202           *fac_shield(i)*fac_shield(j)
5203 !C Now derivative over shield:
5204           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5205          (shield_mode.gt.0)) then
5206 !C          print *,i,j
5207
5208           do ilist=1,ishield_list(i)
5209            iresshield=shield_list(ilist,i)
5210            do k=1,3
5211            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5212 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5213            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5214                    rlocshield &
5215             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5216             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5217            +rlocshield
5218            enddo
5219           enddo
5220           do ilist=1,ishield_list(j)
5221            iresshield=shield_list(ilist,j)
5222            do k=1,3
5223 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5224            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5225            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5226                    rlocshield  &
5227            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5228            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5229                   +rlocshield
5230 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5231
5232            enddo
5233           enddo
5234           do k=1,3
5235             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5236                    grad_shield(k,i)*eello_t4/fac_shield(i)
5237             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5238                    grad_shield(k,j)*eello_t4/fac_shield(j)
5239             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5240                    grad_shield(k,i)*eello_t4/fac_shield(i)
5241             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5242                    grad_shield(k,j)*eello_t4/fac_shield(j)
5243 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5244            enddo
5245            endif
5246 #ifdef NEWCORR
5247         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5248                        -(gs13+gsE13+gsEE1)*wturn4&
5249        *fac_shield(i)*fac_shield(j)
5250         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5251                          -(gs23+gs21+gsEE2)*wturn4&
5252        *fac_shield(i)*fac_shield(j)
5253
5254         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5255                          -(gs32+gsE31+gsEE3)*wturn4&
5256        *fac_shield(i)*fac_shield(j)
5257
5258 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5259 !c     &   gs2
5260 #endif
5261         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5262            'eturn4',i,j,-(s1+s2+s3)
5263 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5264 !d     &    ' eello_turn4_num',8*eello_turn4_num
5265 ! Derivatives in gamma(i)
5266         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5267         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5268         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5269         s1=scalar2(b1(1,i+1),auxvec(1))
5270         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5271         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5272         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5273        *fac_shield(i)*fac_shield(j)  &
5274        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5275
5276 ! Derivatives in gamma(i+1)
5277         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5278         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5279         s2=scalar2(b1(1,iti1),auxvec(1))
5280         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5281         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5282         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5283         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5284        *fac_shield(i)*fac_shield(j)  &
5285        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5286
5287 ! Derivatives in gamma(i+2)
5288         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5289         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5290         s1=scalar2(b1(1,iti2),auxvec(1))
5291         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5292         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5293         s2=scalar2(b1(1,iti1),auxvec(1))
5294         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5295         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5296         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5297         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5298        *fac_shield(i)*fac_shield(j)  &
5299        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5300
5301 ! Cartesian derivatives
5302 ! Derivatives of this turn contributions in DC(i+2)
5303         if (j.lt.nres-1) then
5304           do l=1,3
5305             a_temp(1,1)=agg(l,1)
5306             a_temp(1,2)=agg(l,2)
5307             a_temp(2,1)=agg(l,3)
5308             a_temp(2,2)=agg(l,4)
5309             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5310             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5311             s1=scalar2(b1(1,iti2),auxvec(1))
5312             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5313             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5314             s2=scalar2(b1(1,iti1),auxvec(1))
5315             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5316             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5317             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5318             ggg(l)=-(s1+s2+s3)
5319             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5320        *fac_shield(i)*fac_shield(j)  &
5321        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5322
5323           enddo
5324         endif
5325 ! Remaining derivatives of this turn contribution
5326         do l=1,3
5327           a_temp(1,1)=aggi(l,1)
5328           a_temp(1,2)=aggi(l,2)
5329           a_temp(2,1)=aggi(l,3)
5330           a_temp(2,2)=aggi(l,4)
5331           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5332           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5333           s1=scalar2(b1(1,iti2),auxvec(1))
5334           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5335           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5336           s2=scalar2(b1(1,iti1),auxvec(1))
5337           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5338           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5339           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5340           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5341          *fac_shield(i)*fac_shield(j)  &
5342          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5343
5344
5345           a_temp(1,1)=aggi1(l,1)
5346           a_temp(1,2)=aggi1(l,2)
5347           a_temp(2,1)=aggi1(l,3)
5348           a_temp(2,2)=aggi1(l,4)
5349           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5350           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5351           s1=scalar2(b1(1,iti2),auxvec(1))
5352           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5353           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5354           s2=scalar2(b1(1,iti1),auxvec(1))
5355           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5356           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5357           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5358           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5359          *fac_shield(i)*fac_shield(j)  &
5360          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5361
5362
5363           a_temp(1,1)=aggj(l,1)
5364           a_temp(1,2)=aggj(l,2)
5365           a_temp(2,1)=aggj(l,3)
5366           a_temp(2,2)=aggj(l,4)
5367           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5368           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5369           s1=scalar2(b1(1,iti2),auxvec(1))
5370           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5371           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5372           s2=scalar2(b1(1,iti1),auxvec(1))
5373           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5374           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5375           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5376 !        if (j.lt.nres-1) then
5377           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5378          *fac_shield(i)*fac_shield(j)  &
5379          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5380 !        endif
5381
5382           a_temp(1,1)=aggj1(l,1)
5383           a_temp(1,2)=aggj1(l,2)
5384           a_temp(2,1)=aggj1(l,3)
5385           a_temp(2,2)=aggj1(l,4)
5386           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5387           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5388           s1=scalar2(b1(1,iti2),auxvec(1))
5389           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5390           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5391           s2=scalar2(b1(1,iti1),auxvec(1))
5392           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5393           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5394           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5395 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5396 !        if (j.lt.nres-1) then
5397 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5398           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5399          *fac_shield(i)*fac_shield(j)  &
5400          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5401 !            if (shield_mode.gt.0) then
5402 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5403 !            else
5404 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5405 !            endif
5406 !         endif
5407         enddo
5408          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5409           ssgradlipi*eello_t4/4.0d0*lipscale
5410          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5411           ssgradlipj*eello_t4/4.0d0*lipscale
5412          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5413           ssgradlipi*eello_t4/4.0d0*lipscale
5414          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5415           ssgradlipj*eello_t4/4.0d0*lipscale
5416
5417       return
5418       end subroutine eturn4
5419 !-----------------------------------------------------------------------------
5420       subroutine unormderiv(u,ugrad,unorm,ungrad)
5421 ! This subroutine computes the derivatives of a normalized vector u, given
5422 ! the derivatives computed without normalization conditions, ugrad. Returns
5423 ! ungrad.
5424 !      implicit none
5425       real(kind=8),dimension(3) :: u,vec
5426       real(kind=8),dimension(3,3) ::ugrad,ungrad
5427       real(kind=8) :: unorm      !,scalar
5428       integer :: i,j
5429 !      write (2,*) 'ugrad',ugrad
5430 !      write (2,*) 'u',u
5431       do i=1,3
5432         vec(i)=scalar(ugrad(1,i),u(1))
5433       enddo
5434 !      write (2,*) 'vec',vec
5435       do i=1,3
5436         do j=1,3
5437           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5438         enddo
5439       enddo
5440 !      write (2,*) 'ungrad',ungrad
5441       return
5442       end subroutine unormderiv
5443 !-----------------------------------------------------------------------------
5444       subroutine escp_soft_sphere(evdw2,evdw2_14)
5445 !
5446 ! This subroutine calculates the excluded-volume interaction energy between
5447 ! peptide-group centers and side chains and its gradient in virtual-bond and
5448 ! side-chain vectors.
5449 !
5450 !      implicit real*8 (a-h,o-z)
5451 !      include 'DIMENSIONS'
5452 !      include 'COMMON.GEO'
5453 !      include 'COMMON.VAR'
5454 !      include 'COMMON.LOCAL'
5455 !      include 'COMMON.CHAIN'
5456 !      include 'COMMON.DERIV'
5457 !      include 'COMMON.INTERACT'
5458 !      include 'COMMON.FFIELD'
5459 !      include 'COMMON.IOUNITS'
5460 !      include 'COMMON.CONTROL'
5461       real(kind=8),dimension(3) :: ggg
5462 !el local variables
5463       integer :: i,iint,j,k,iteli,itypj
5464       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5465                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5466
5467       evdw2=0.0D0
5468       evdw2_14=0.0d0
5469       r0_scp=4.5d0
5470 !d    print '(a)','Enter ESCP'
5471 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5472       do i=iatscp_s,iatscp_e
5473         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5474         iteli=itel(i)
5475         xi=0.5D0*(c(1,i)+c(1,i+1))
5476         yi=0.5D0*(c(2,i)+c(2,i+1))
5477         zi=0.5D0*(c(3,i)+c(3,i+1))
5478
5479         do iint=1,nscp_gr(i)
5480
5481         do j=iscpstart(i,iint),iscpend(i,iint)
5482           if (itype(j,1).eq.ntyp1) cycle
5483           itypj=iabs(itype(j,1))
5484 ! Uncomment following three lines for SC-p interactions
5485 !         xj=c(1,nres+j)-xi
5486 !         yj=c(2,nres+j)-yi
5487 !         zj=c(3,nres+j)-zi
5488 ! Uncomment following three lines for Ca-p interactions
5489           xj=c(1,j)-xi
5490           yj=c(2,j)-yi
5491           zj=c(3,j)-zi
5492           rij=xj*xj+yj*yj+zj*zj
5493           r0ij=r0_scp
5494           r0ijsq=r0ij*r0ij
5495           if (rij.lt.r0ijsq) then
5496             evdwij=0.25d0*(rij-r0ijsq)**2
5497             fac=rij-r0ijsq
5498           else
5499             evdwij=0.0d0
5500             fac=0.0d0
5501           endif
5502           evdw2=evdw2+evdwij
5503 !
5504 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5505 !
5506           ggg(1)=xj*fac
5507           ggg(2)=yj*fac
5508           ggg(3)=zj*fac
5509 !grad          if (j.lt.i) then
5510 !d          write (iout,*) 'j<i'
5511 ! Uncomment following three lines for SC-p interactions
5512 !           do k=1,3
5513 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5514 !           enddo
5515 !grad          else
5516 !d          write (iout,*) 'j>i'
5517 !grad            do k=1,3
5518 !grad              ggg(k)=-ggg(k)
5519 ! Uncomment following line for SC-p interactions
5520 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5521 !grad            enddo
5522 !grad          endif
5523 !grad          do k=1,3
5524 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5525 !grad          enddo
5526 !grad          kstart=min0(i+1,j)
5527 !grad          kend=max0(i-1,j-1)
5528 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5529 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5530 !grad          do k=kstart,kend
5531 !grad            do l=1,3
5532 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5533 !grad            enddo
5534 !grad          enddo
5535           do k=1,3
5536             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5537             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5538           enddo
5539         enddo
5540
5541         enddo ! iint
5542       enddo ! i
5543       return
5544       end subroutine escp_soft_sphere
5545 !-----------------------------------------------------------------------------
5546       subroutine escp(evdw2,evdw2_14)
5547 !
5548 ! This subroutine calculates the excluded-volume interaction energy between
5549 ! peptide-group centers and side chains and its gradient in virtual-bond and
5550 ! side-chain vectors.
5551 !
5552 !      implicit real*8 (a-h,o-z)
5553 !      include 'DIMENSIONS'
5554 !      include 'COMMON.GEO'
5555 !      include 'COMMON.VAR'
5556 !      include 'COMMON.LOCAL'
5557 !      include 'COMMON.CHAIN'
5558 !      include 'COMMON.DERIV'
5559 !      include 'COMMON.INTERACT'
5560 !      include 'COMMON.FFIELD'
5561 !      include 'COMMON.IOUNITS'
5562 !      include 'COMMON.CONTROL'
5563       real(kind=8),dimension(3) :: ggg
5564 !el local variables
5565       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5566       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5567                    e1,e2,evdwij,rij
5568       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5569                     dist_temp, dist_init
5570       integer xshift,yshift,zshift
5571
5572       evdw2=0.0D0
5573       evdw2_14=0.0d0
5574 !d    print '(a)','Enter ESCP'
5575 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5576 !      do i=iatscp_s,iatscp_e
5577        do icont=g_listscp_start,g_listscp_end
5578         i=newcontlistscpi(icont)
5579         j=newcontlistscpj(icont)
5580         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5581         iteli=itel(i)
5582         xi=0.5D0*(c(1,i)+c(1,i+1))
5583         yi=0.5D0*(c(2,i)+c(2,i+1))
5584         zi=0.5D0*(c(3,i)+c(3,i+1))
5585           xi=mod(xi,boxxsize)
5586           if (xi.lt.0) xi=xi+boxxsize
5587           yi=mod(yi,boxysize)
5588           if (yi.lt.0) yi=yi+boxysize
5589           zi=mod(zi,boxzsize)
5590           if (zi.lt.0) zi=zi+boxzsize
5591
5592 !        do iint=1,nscp_gr(i)
5593
5594 !        do j=iscpstart(i,iint),iscpend(i,iint)
5595           itypj=iabs(itype(j,1))
5596           if (itypj.eq.ntyp1) cycle
5597 ! Uncomment following three lines for SC-p interactions
5598 !         xj=c(1,nres+j)-xi
5599 !         yj=c(2,nres+j)-yi
5600 !         zj=c(3,nres+j)-zi
5601 ! Uncomment following three lines for Ca-p interactions
5602 !          xj=c(1,j)-xi
5603 !          yj=c(2,j)-yi
5604 !          zj=c(3,j)-zi
5605           xj=c(1,j)
5606           yj=c(2,j)
5607           zj=c(3,j)
5608           xj=mod(xj,boxxsize)
5609           if (xj.lt.0) xj=xj+boxxsize
5610           yj=mod(yj,boxysize)
5611           if (yj.lt.0) yj=yj+boxysize
5612           zj=mod(zj,boxzsize)
5613           if (zj.lt.0) zj=zj+boxzsize
5614       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5615       xj_safe=xj
5616       yj_safe=yj
5617       zj_safe=zj
5618       subchap=0
5619       do xshift=-1,1
5620       do yshift=-1,1
5621       do zshift=-1,1
5622           xj=xj_safe+xshift*boxxsize
5623           yj=yj_safe+yshift*boxysize
5624           zj=zj_safe+zshift*boxzsize
5625           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5626           if(dist_temp.lt.dist_init) then
5627             dist_init=dist_temp
5628             xj_temp=xj
5629             yj_temp=yj
5630             zj_temp=zj
5631             subchap=1
5632           endif
5633        enddo
5634        enddo
5635        enddo
5636        if (subchap.eq.1) then
5637           xj=xj_temp-xi
5638           yj=yj_temp-yi
5639           zj=zj_temp-zi
5640        else
5641           xj=xj_safe-xi
5642           yj=yj_safe-yi
5643           zj=zj_safe-zi
5644        endif
5645
5646           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5647           rij=dsqrt(1.0d0/rrij)
5648             sss_ele_cut=sscale_ele(rij)
5649             sss_ele_grad=sscagrad_ele(rij)
5650 !            print *,sss_ele_cut,sss_ele_grad,&
5651 !            (rij),r_cut_ele,rlamb_ele
5652             if (sss_ele_cut.le.0.0) cycle
5653           fac=rrij**expon2
5654           e1=fac*fac*aad(itypj,iteli)
5655           e2=fac*bad(itypj,iteli)
5656           if (iabs(j-i) .le. 2) then
5657             e1=scal14*e1
5658             e2=scal14*e2
5659             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5660           endif
5661           evdwij=e1+e2
5662           evdw2=evdw2+evdwij*sss_ele_cut
5663 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5664 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5665           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5666              'evdw2',i,j,evdwij
5667 !
5668 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5669 !
5670           fac=-(evdwij+e1)*rrij*sss_ele_cut
5671           fac=fac+evdwij*sss_ele_grad/rij/expon
5672           ggg(1)=xj*fac
5673           ggg(2)=yj*fac
5674           ggg(3)=zj*fac
5675 !grad          if (j.lt.i) then
5676 !d          write (iout,*) 'j<i'
5677 ! Uncomment following three lines for SC-p interactions
5678 !           do k=1,3
5679 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5680 !           enddo
5681 !grad          else
5682 !d          write (iout,*) 'j>i'
5683 !grad            do k=1,3
5684 !grad              ggg(k)=-ggg(k)
5685 ! Uncomment following line for SC-p interactions
5686 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5687 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5688 !grad            enddo
5689 !grad          endif
5690 !grad          do k=1,3
5691 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5692 !grad          enddo
5693 !grad          kstart=min0(i+1,j)
5694 !grad          kend=max0(i-1,j-1)
5695 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5696 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5697 !grad          do k=kstart,kend
5698 !grad            do l=1,3
5699 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5700 !grad            enddo
5701 !grad          enddo
5702           do k=1,3
5703             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5704             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5705           enddo
5706 !        enddo
5707
5708 !        enddo ! iint
5709       enddo ! i
5710       do i=1,nct
5711         do j=1,3
5712           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5713           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5714           gradx_scp(j,i)=expon*gradx_scp(j,i)
5715         enddo
5716       enddo
5717 !******************************************************************************
5718 !
5719 !                              N O T E !!!
5720 !
5721 ! To save time the factor EXPON has been extracted from ALL components
5722 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5723 ! use!
5724 !
5725 !******************************************************************************
5726       return
5727       end subroutine escp
5728 !-----------------------------------------------------------------------------
5729       subroutine edis(ehpb)
5730 !
5731 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5732 !
5733 !      implicit real*8 (a-h,o-z)
5734 !      include 'DIMENSIONS'
5735 !      include 'COMMON.SBRIDGE'
5736 !      include 'COMMON.CHAIN'
5737 !      include 'COMMON.DERIV'
5738 !      include 'COMMON.VAR'
5739 !      include 'COMMON.INTERACT'
5740 !      include 'COMMON.IOUNITS'
5741       real(kind=8),dimension(3) :: ggg
5742 !el local variables
5743       integer :: i,j,ii,jj,iii,jjj,k
5744       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5745
5746       ehpb=0.0D0
5747 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5748 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5749       if (link_end.eq.0) return
5750       do i=link_start,link_end
5751 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5752 ! CA-CA distance used in regularization of structure.
5753         ii=ihpb(i)
5754         jj=jhpb(i)
5755 ! iii and jjj point to the residues for which the distance is assigned.
5756         if (ii.gt.nres) then
5757           iii=ii-nres
5758           jjj=jj-nres
5759         else
5760           iii=ii
5761           jjj=jj
5762         endif
5763 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5764 !     &    dhpb(i),dhpb1(i),forcon(i)
5765 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5766 !    distance and angle dependent SS bond potential.
5767 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5768 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5769         if (.not.dyn_ss .and. i.le.nss) then
5770 ! 15/02/13 CC dynamic SSbond - additional check
5771          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5772         iabs(itype(jjj,1)).eq.1) then
5773           call ssbond_ene(iii,jjj,eij)
5774           ehpb=ehpb+2*eij
5775 !d          write (iout,*) "eij",eij
5776          endif
5777         else if (ii.gt.nres .and. jj.gt.nres) then
5778 !c Restraints from contact prediction
5779           dd=dist(ii,jj)
5780           if (constr_dist.eq.11) then
5781             ehpb=ehpb+fordepth(i)**4.0d0 &
5782                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5783             fac=fordepth(i)**4.0d0 &
5784                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5785           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5786             ehpb,fordepth(i),dd
5787            else
5788           if (dhpb1(i).gt.0.0d0) then
5789             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5790             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5791 !c            write (iout,*) "beta nmr",
5792 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5793           else
5794             dd=dist(ii,jj)
5795             rdis=dd-dhpb(i)
5796 !C Get the force constant corresponding to this distance.
5797             waga=forcon(i)
5798 !C Calculate the contribution to energy.
5799             ehpb=ehpb+waga*rdis*rdis
5800 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5801 !C
5802 !C Evaluate gradient.
5803 !C
5804             fac=waga*rdis/dd
5805           endif
5806           endif
5807           do j=1,3
5808             ggg(j)=fac*(c(j,jj)-c(j,ii))
5809           enddo
5810           do j=1,3
5811             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5812             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5813           enddo
5814           do k=1,3
5815             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5816             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5817           enddo
5818         else
5819           dd=dist(ii,jj)
5820           if (constr_dist.eq.11) then
5821             ehpb=ehpb+fordepth(i)**4.0d0 &
5822                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5823             fac=fordepth(i)**4.0d0 &
5824                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5825           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5826          ehpb,fordepth(i),dd
5827            else
5828           if (dhpb1(i).gt.0.0d0) then
5829             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5830             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5831 !c            write (iout,*) "alph nmr",
5832 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5833           else
5834             rdis=dd-dhpb(i)
5835 !C Get the force constant corresponding to this distance.
5836             waga=forcon(i)
5837 !C Calculate the contribution to energy.
5838             ehpb=ehpb+waga*rdis*rdis
5839 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5840 !C
5841 !C Evaluate gradient.
5842 !C
5843             fac=waga*rdis/dd
5844           endif
5845           endif
5846
5847             do j=1,3
5848               ggg(j)=fac*(c(j,jj)-c(j,ii))
5849             enddo
5850 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5851 !C If this is a SC-SC distance, we need to calculate the contributions to the
5852 !C Cartesian gradient in the SC vectors (ghpbx).
5853           if (iii.lt.ii) then
5854           do j=1,3
5855             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5856             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5857           enddo
5858           endif
5859 !cgrad        do j=iii,jjj-1
5860 !cgrad          do k=1,3
5861 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5862 !cgrad          enddo
5863 !cgrad        enddo
5864           do k=1,3
5865             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5866             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5867           enddo
5868         endif
5869       enddo
5870       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5871
5872       return
5873       end subroutine edis
5874 !-----------------------------------------------------------------------------
5875       subroutine ssbond_ene(i,j,eij)
5876 !
5877 ! Calculate the distance and angle dependent SS-bond potential energy
5878 ! using a free-energy function derived based on RHF/6-31G** ab initio
5879 ! calculations of diethyl disulfide.
5880 !
5881 ! A. Liwo and U. Kozlowska, 11/24/03
5882 !
5883 !      implicit real*8 (a-h,o-z)
5884 !      include 'DIMENSIONS'
5885 !      include 'COMMON.SBRIDGE'
5886 !      include 'COMMON.CHAIN'
5887 !      include 'COMMON.DERIV'
5888 !      include 'COMMON.LOCAL'
5889 !      include 'COMMON.INTERACT'
5890 !      include 'COMMON.VAR'
5891 !      include 'COMMON.IOUNITS'
5892       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5893 !el local variables
5894       integer :: i,j,itypi,itypj,k
5895       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5896                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5897                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5898                    cosphi,ggk
5899
5900       itypi=iabs(itype(i,1))
5901       xi=c(1,nres+i)
5902       yi=c(2,nres+i)
5903       zi=c(3,nres+i)
5904       dxi=dc_norm(1,nres+i)
5905       dyi=dc_norm(2,nres+i)
5906       dzi=dc_norm(3,nres+i)
5907 !      dsci_inv=dsc_inv(itypi)
5908       dsci_inv=vbld_inv(nres+i)
5909       itypj=iabs(itype(j,1))
5910 !      dscj_inv=dsc_inv(itypj)
5911       dscj_inv=vbld_inv(nres+j)
5912       xj=c(1,nres+j)-xi
5913       yj=c(2,nres+j)-yi
5914       zj=c(3,nres+j)-zi
5915       dxj=dc_norm(1,nres+j)
5916       dyj=dc_norm(2,nres+j)
5917       dzj=dc_norm(3,nres+j)
5918       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5919       rij=dsqrt(rrij)
5920       erij(1)=xj*rij
5921       erij(2)=yj*rij
5922       erij(3)=zj*rij
5923       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5924       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5925       om12=dxi*dxj+dyi*dyj+dzi*dzj
5926       do k=1,3
5927         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5928         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5929       enddo
5930       rij=1.0d0/rij
5931       deltad=rij-d0cm
5932       deltat1=1.0d0-om1
5933       deltat2=1.0d0+om2
5934       deltat12=om2-om1+2.0d0
5935       cosphi=om12-om1*om2
5936       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5937         +akct*deltad*deltat12 &
5938         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5939 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5940 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5941 !     &  " deltat12",deltat12," eij",eij
5942       ed=2*akcm*deltad+akct*deltat12
5943       pom1=akct*deltad
5944       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5945       eom1=-2*akth*deltat1-pom1-om2*pom2
5946       eom2= 2*akth*deltat2+pom1-om1*pom2
5947       eom12=pom2
5948       do k=1,3
5949         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5950         ghpbx(k,i)=ghpbx(k,i)-ggk &
5951                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5952                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5953         ghpbx(k,j)=ghpbx(k,j)+ggk &
5954                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5955                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5956         ghpbc(k,i)=ghpbc(k,i)-ggk
5957         ghpbc(k,j)=ghpbc(k,j)+ggk
5958       enddo
5959 !
5960 ! Calculate the components of the gradient in DC and X
5961 !
5962 !grad      do k=i,j-1
5963 !grad        do l=1,3
5964 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5965 !grad        enddo
5966 !grad      enddo
5967       return
5968       end subroutine ssbond_ene
5969 !-----------------------------------------------------------------------------
5970       subroutine ebond(estr)
5971 !
5972 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5973 !
5974 !      implicit real*8 (a-h,o-z)
5975 !      include 'DIMENSIONS'
5976 !      include 'COMMON.LOCAL'
5977 !      include 'COMMON.GEO'
5978 !      include 'COMMON.INTERACT'
5979 !      include 'COMMON.DERIV'
5980 !      include 'COMMON.VAR'
5981 !      include 'COMMON.CHAIN'
5982 !      include 'COMMON.IOUNITS'
5983 !      include 'COMMON.NAMES'
5984 !      include 'COMMON.FFIELD'
5985 !      include 'COMMON.CONTROL'
5986 !      include 'COMMON.SETUP'
5987       real(kind=8),dimension(3) :: u,ud
5988 !el local variables
5989       integer :: i,j,iti,nbi,k
5990       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5991                    uprod1,uprod2
5992
5993       estr=0.0d0
5994       estr1=0.0d0
5995 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5996 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5997
5998       do i=ibondp_start,ibondp_end
5999         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
6000         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
6001 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6002 !C          do j=1,3
6003 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
6004 !C            *dc(j,i-1)/vbld(i)
6005 !C          enddo
6006 !C          if (energy_dec) write(iout,*) &
6007 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6008         diff = vbld(i)-vbldpDUM
6009         else
6010         diff = vbld(i)-vbldp0
6011         endif
6012         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
6013            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6014         estr=estr+diff*diff
6015         do j=1,3
6016           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6017         enddo
6018 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6019 !        endif
6020       enddo
6021       estr=0.5d0*AKP*estr+estr1
6022 !      print *,"estr_bb",estr,AKP
6023 !
6024 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6025 !
6026       do i=ibond_start,ibond_end
6027         iti=iabs(itype(i,1))
6028         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
6029         if (iti.ne.10 .and. iti.ne.ntyp1) then
6030           nbi=nbondterm(iti)
6031           if (nbi.eq.1) then
6032             diff=vbld(i+nres)-vbldsc0(1,iti)
6033             if (energy_dec) write (iout,*) &
6034             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6035             AKSC(1,iti),AKSC(1,iti)*diff*diff
6036             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6037 !            print *,"estr_sc",estr
6038             do j=1,3
6039               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6040             enddo
6041           else
6042             do j=1,nbi
6043               diff=vbld(i+nres)-vbldsc0(j,iti)
6044               ud(j)=aksc(j,iti)*diff
6045               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6046             enddo
6047             uprod=u(1)
6048             do j=2,nbi
6049               uprod=uprod*u(j)
6050             enddo
6051             usum=0.0d0
6052             usumsqder=0.0d0
6053             do j=1,nbi
6054               uprod1=1.0d0
6055               uprod2=1.0d0
6056               do k=1,nbi
6057                 if (k.ne.j) then
6058                   uprod1=uprod1*u(k)
6059                   uprod2=uprod2*u(k)*u(k)
6060                 endif
6061               enddo
6062               usum=usum+uprod1
6063               usumsqder=usumsqder+ud(j)*uprod2
6064             enddo
6065             estr=estr+uprod/usum
6066 !            print *,"estr_sc",estr,i
6067
6068              if (energy_dec) write (iout,*) &
6069             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
6070             AKSC(1,iti),uprod/usum
6071             do j=1,3
6072              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6073             enddo
6074           endif
6075         endif
6076       enddo
6077       return
6078       end subroutine ebond
6079 #ifdef CRYST_THETA
6080 !-----------------------------------------------------------------------------
6081       subroutine ebend(etheta)
6082 !
6083 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6084 ! angles gamma and its derivatives in consecutive thetas and gammas.
6085 !
6086       use comm_calcthet
6087 !      implicit real*8 (a-h,o-z)
6088 !      include 'DIMENSIONS'
6089 !      include 'COMMON.LOCAL'
6090 !      include 'COMMON.GEO'
6091 !      include 'COMMON.INTERACT'
6092 !      include 'COMMON.DERIV'
6093 !      include 'COMMON.VAR'
6094 !      include 'COMMON.CHAIN'
6095 !      include 'COMMON.IOUNITS'
6096 !      include 'COMMON.NAMES'
6097 !      include 'COMMON.FFIELD'
6098 !      include 'COMMON.CONTROL'
6099 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6100 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6101 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6102 !el      integer :: it
6103 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6104 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6105 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6106 !el local variables
6107       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
6108        ichir21,ichir22
6109       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
6110        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
6111        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
6112       real(kind=8),dimension(2) :: y,z
6113
6114       delta=0.02d0*pi
6115 !      time11=dexp(-2*time)
6116 !      time12=1.0d0
6117       etheta=0.0D0
6118 !     write (*,'(a,i2)') 'EBEND ICG=',icg
6119       do i=ithet_start,ithet_end
6120         if (itype(i-1,1).eq.ntyp1) cycle
6121 ! Zero the energy function and its derivative at 0 or pi.
6122         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6123         it=itype(i-1,1)
6124         ichir1=isign(1,itype(i-2,1))
6125         ichir2=isign(1,itype(i,1))
6126          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
6127          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
6128          if (itype(i-1,1).eq.10) then
6129           itype1=isign(10,itype(i-2,1))
6130           ichir11=isign(1,itype(i-2,1))
6131           ichir12=isign(1,itype(i-2,1))
6132           itype2=isign(10,itype(i,1))
6133           ichir21=isign(1,itype(i,1))
6134           ichir22=isign(1,itype(i,1))
6135          endif
6136
6137         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
6138 #ifdef OSF
6139           phii=phi(i)
6140           if (phii.ne.phii) phii=150.0
6141 #else
6142           phii=phi(i)
6143 #endif
6144           y(1)=dcos(phii)
6145           y(2)=dsin(phii)
6146         else
6147           y(1)=0.0D0
6148           y(2)=0.0D0
6149         endif
6150         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
6151 #ifdef OSF
6152           phii1=phi(i+1)
6153           if (phii1.ne.phii1) phii1=150.0
6154           phii1=pinorm(phii1)
6155           z(1)=cos(phii1)
6156 #else
6157           phii1=phi(i+1)
6158           z(1)=dcos(phii1)
6159 #endif
6160           z(2)=dsin(phii1)
6161         else
6162           z(1)=0.0D0
6163           z(2)=0.0D0
6164         endif
6165 ! Calculate the "mean" value of theta from the part of the distribution
6166 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6167 ! In following comments this theta will be referred to as t_c.
6168         thet_pred_mean=0.0d0
6169         do k=1,2
6170             athetk=athet(k,it,ichir1,ichir2)
6171             bthetk=bthet(k,it,ichir1,ichir2)
6172           if (it.eq.10) then
6173              athetk=athet(k,itype1,ichir11,ichir12)
6174              bthetk=bthet(k,itype2,ichir21,ichir22)
6175           endif
6176          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6177         enddo
6178         dthett=thet_pred_mean*ssd
6179         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6180 ! Derivatives of the "mean" values in gamma1 and gamma2.
6181         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6182                +athet(2,it,ichir1,ichir2)*y(1))*ss
6183         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6184                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6185          if (it.eq.10) then
6186         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6187              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6188         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6189                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6190          endif
6191         if (theta(i).gt.pi-delta) then
6192           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6193                E_tc0)
6194           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6195           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6196           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6197               E_theta)
6198           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6199               E_tc)
6200         else if (theta(i).lt.delta) then
6201           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6202           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6203           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6204               E_theta)
6205           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6206           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6207               E_tc)
6208         else
6209           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6210               E_theta,E_tc)
6211         endif
6212         etheta=etheta+ethetai
6213         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6214             'ebend',i,ethetai
6215         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6216         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6217         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6218       enddo
6219 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6220
6221 ! Ufff.... We've done all this!!!
6222       return
6223       end subroutine ebend
6224 !-----------------------------------------------------------------------------
6225       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6226
6227       use comm_calcthet
6228 !      implicit real*8 (a-h,o-z)
6229 !      include 'DIMENSIONS'
6230 !      include 'COMMON.LOCAL'
6231 !      include 'COMMON.IOUNITS'
6232 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6233 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6234 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6235       integer :: i,j,k
6236       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6237 !el      integer :: it
6238 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6239 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6240 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6241 !el local variables
6242       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6243        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6244
6245 ! Calculate the contributions to both Gaussian lobes.
6246 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6247 ! The "polynomial part" of the "standard deviation" of this part of
6248 ! the distribution.
6249         sig=polthet(3,it)
6250         do j=2,0,-1
6251           sig=sig*thet_pred_mean+polthet(j,it)
6252         enddo
6253 ! Derivative of the "interior part" of the "standard deviation of the"
6254 ! gamma-dependent Gaussian lobe in t_c.
6255         sigtc=3*polthet(3,it)
6256         do j=2,1,-1
6257           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6258         enddo
6259         sigtc=sig*sigtc
6260 ! Set the parameters of both Gaussian lobes of the distribution.
6261 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6262         fac=sig*sig+sigc0(it)
6263         sigcsq=fac+fac
6264         sigc=1.0D0/sigcsq
6265 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6266         sigsqtc=-4.0D0*sigcsq*sigtc
6267 !       print *,i,sig,sigtc,sigsqtc
6268 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6269         sigtc=-sigtc/(fac*fac)
6270 ! Following variable is sigma(t_c)**(-2)
6271         sigcsq=sigcsq*sigcsq
6272         sig0i=sig0(it)
6273         sig0inv=1.0D0/sig0i**2
6274         delthec=thetai-thet_pred_mean
6275         delthe0=thetai-theta0i
6276         term1=-0.5D0*sigcsq*delthec*delthec
6277         term2=-0.5D0*sig0inv*delthe0*delthe0
6278 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6279 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6280 ! to the energy (this being the log of the distribution) at the end of energy
6281 ! term evaluation for this virtual-bond angle.
6282         if (term1.gt.term2) then
6283           termm=term1
6284           term2=dexp(term2-termm)
6285           term1=1.0d0
6286         else
6287           termm=term2
6288           term1=dexp(term1-termm)
6289           term2=1.0d0
6290         endif
6291 ! The ratio between the gamma-independent and gamma-dependent lobes of
6292 ! the distribution is a Gaussian function of thet_pred_mean too.
6293         diffak=gthet(2,it)-thet_pred_mean
6294         ratak=diffak/gthet(3,it)**2
6295         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6296 ! Let's differentiate it in thet_pred_mean NOW.
6297         aktc=ak*ratak
6298 ! Now put together the distribution terms to make complete distribution.
6299         termexp=term1+ak*term2
6300         termpre=sigc+ak*sig0i
6301 ! Contribution of the bending energy from this theta is just the -log of
6302 ! the sum of the contributions from the two lobes and the pre-exponential
6303 ! factor. Simple enough, isn't it?
6304         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6305 ! NOW the derivatives!!!
6306 ! 6/6/97 Take into account the deformation.
6307         E_theta=(delthec*sigcsq*term1 &
6308              +ak*delthe0*sig0inv*term2)/termexp
6309         E_tc=((sigtc+aktc*sig0i)/termpre &
6310             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6311              aktc*term2)/termexp)
6312       return
6313       end subroutine theteng
6314 #else
6315 !-----------------------------------------------------------------------------
6316       subroutine ebend(etheta)
6317 !
6318 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6319 ! angles gamma and its derivatives in consecutive thetas and gammas.
6320 ! ab initio-derived potentials from
6321 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6322 !
6323 !      implicit real*8 (a-h,o-z)
6324 !      include 'DIMENSIONS'
6325 !      include 'COMMON.LOCAL'
6326 !      include 'COMMON.GEO'
6327 !      include 'COMMON.INTERACT'
6328 !      include 'COMMON.DERIV'
6329 !      include 'COMMON.VAR'
6330 !      include 'COMMON.CHAIN'
6331 !      include 'COMMON.IOUNITS'
6332 !      include 'COMMON.NAMES'
6333 !      include 'COMMON.FFIELD'
6334 !      include 'COMMON.CONTROL'
6335       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6336       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6337       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6338       logical :: lprn=.false., lprn1=.false.
6339 !el local variables
6340       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6341       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6342       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6343 ! local variables for constrains
6344       real(kind=8) :: difi,thetiii
6345        integer itheta
6346 !      write(iout,*) "in ebend",ithet_start,ithet_end
6347       call flush(iout)
6348       etheta=0.0D0
6349       do i=ithet_start,ithet_end
6350         if (itype(i-1,1).eq.ntyp1) cycle
6351         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6352         if (iabs(itype(i+1,1)).eq.20) iblock=2
6353         if (iabs(itype(i+1,1)).ne.20) iblock=1
6354         dethetai=0.0d0
6355         dephii=0.0d0
6356         dephii1=0.0d0
6357         theti2=0.5d0*theta(i)
6358         ityp2=ithetyp((itype(i-1,1)))
6359         do k=1,nntheterm
6360           coskt(k)=dcos(k*theti2)
6361           sinkt(k)=dsin(k*theti2)
6362         enddo
6363         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6364 #ifdef OSF
6365           phii=phi(i)
6366           if (phii.ne.phii) phii=150.0
6367 #else
6368           phii=phi(i)
6369 #endif
6370           ityp1=ithetyp((itype(i-2,1)))
6371 ! propagation of chirality for glycine type
6372           do k=1,nsingle
6373             cosph1(k)=dcos(k*phii)
6374             sinph1(k)=dsin(k*phii)
6375           enddo
6376         else
6377           phii=0.0d0
6378           ityp1=ithetyp(itype(i-2,1))
6379           do k=1,nsingle
6380             cosph1(k)=0.0d0
6381             sinph1(k)=0.0d0
6382           enddo
6383         endif
6384         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6385 #ifdef OSF
6386           phii1=phi(i+1)
6387           if (phii1.ne.phii1) phii1=150.0
6388           phii1=pinorm(phii1)
6389 #else
6390           phii1=phi(i+1)
6391 #endif
6392           ityp3=ithetyp((itype(i,1)))
6393           do k=1,nsingle
6394             cosph2(k)=dcos(k*phii1)
6395             sinph2(k)=dsin(k*phii1)
6396           enddo
6397         else
6398           phii1=0.0d0
6399           ityp3=ithetyp(itype(i,1))
6400           do k=1,nsingle
6401             cosph2(k)=0.0d0
6402             sinph2(k)=0.0d0
6403           enddo
6404         endif
6405         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6406         do k=1,ndouble
6407           do l=1,k-1
6408             ccl=cosph1(l)*cosph2(k-l)
6409             ssl=sinph1(l)*sinph2(k-l)
6410             scl=sinph1(l)*cosph2(k-l)
6411             csl=cosph1(l)*sinph2(k-l)
6412             cosph1ph2(l,k)=ccl-ssl
6413             cosph1ph2(k,l)=ccl+ssl
6414             sinph1ph2(l,k)=scl+csl
6415             sinph1ph2(k,l)=scl-csl
6416           enddo
6417         enddo
6418         if (lprn) then
6419         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6420           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6421         write (iout,*) "coskt and sinkt"
6422         do k=1,nntheterm
6423           write (iout,*) k,coskt(k),sinkt(k)
6424         enddo
6425         endif
6426         do k=1,ntheterm
6427           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6428           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6429             *coskt(k)
6430           if (lprn) &
6431           write (iout,*) "k",k,&
6432            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6433            " ethetai",ethetai
6434         enddo
6435         if (lprn) then
6436         write (iout,*) "cosph and sinph"
6437         do k=1,nsingle
6438           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6439         enddo
6440         write (iout,*) "cosph1ph2 and sinph2ph2"
6441         do k=2,ndouble
6442           do l=1,k-1
6443             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6444                sinph1ph2(l,k),sinph1ph2(k,l)
6445           enddo
6446         enddo
6447         write(iout,*) "ethetai",ethetai
6448         endif
6449         do m=1,ntheterm2
6450           do k=1,nsingle
6451             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6452                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6453                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6454                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6455             ethetai=ethetai+sinkt(m)*aux
6456             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6457             dephii=dephii+k*sinkt(m)* &
6458                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6459                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6460             dephii1=dephii1+k*sinkt(m)* &
6461                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6462                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6463             if (lprn) &
6464             write (iout,*) "m",m," k",k," bbthet", &
6465                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6466                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6467                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6468                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6469           enddo
6470         enddo
6471         if (lprn) &
6472         write(iout,*) "ethetai",ethetai
6473         do m=1,ntheterm3
6474           do k=2,ndouble
6475             do l=1,k-1
6476               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6477                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6478                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6479                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6480               ethetai=ethetai+sinkt(m)*aux
6481               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6482               dephii=dephii+l*sinkt(m)* &
6483                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6484                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6485                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6486                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6487               dephii1=dephii1+(k-l)*sinkt(m)* &
6488                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6489                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6490                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6491                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6492               if (lprn) then
6493               write (iout,*) "m",m," k",k," l",l," ffthet",&
6494                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6495                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6496                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6497                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6498                   " ethetai",ethetai
6499               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6500                   cosph1ph2(k,l)*sinkt(m),&
6501                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6502               endif
6503             enddo
6504           enddo
6505         enddo
6506 10      continue
6507 !        lprn1=.true.
6508         if (lprn1) &
6509           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6510          i,theta(i)*rad2deg,phii*rad2deg,&
6511          phii1*rad2deg,ethetai
6512 !        lprn1=.false.
6513         etheta=etheta+ethetai
6514         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6515                                     'ebend',i,ethetai
6516         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6517         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6518         gloc(nphi+i-2,icg)=wang*dethetai
6519       enddo
6520 !-----------thete constrains
6521 !      if (tor_mode.ne.2) then
6522
6523       return
6524       end subroutine ebend
6525 #endif
6526 #ifdef CRYST_SC
6527 !-----------------------------------------------------------------------------
6528       subroutine esc(escloc)
6529 ! Calculate the local energy of a side chain and its derivatives in the
6530 ! corresponding virtual-bond valence angles THETA and the spherical angles
6531 ! ALPHA and OMEGA.
6532 !
6533       use comm_sccalc
6534 !      implicit real*8 (a-h,o-z)
6535 !      include 'DIMENSIONS'
6536 !      include 'COMMON.GEO'
6537 !      include 'COMMON.LOCAL'
6538 !      include 'COMMON.VAR'
6539 !      include 'COMMON.INTERACT'
6540 !      include 'COMMON.DERIV'
6541 !      include 'COMMON.CHAIN'
6542 !      include 'COMMON.IOUNITS'
6543 !      include 'COMMON.NAMES'
6544 !      include 'COMMON.FFIELD'
6545 !      include 'COMMON.CONTROL'
6546       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6547          ddersc0,ddummy,xtemp,temp
6548 !el      real(kind=8) :: time11,time12,time112,theti
6549       real(kind=8) :: escloc,delta
6550 !el      integer :: it,nlobit
6551 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6552 !el local variables
6553       integer :: i,k
6554       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6555        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6556       delta=0.02d0*pi
6557       escloc=0.0D0
6558 !     write (iout,'(a)') 'ESC'
6559       do i=loc_start,loc_end
6560         it=itype(i,1)
6561         if (it.eq.ntyp1) cycle
6562         if (it.eq.10) goto 1
6563         nlobit=nlob(iabs(it))
6564 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6565 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6566         theti=theta(i+1)-pipol
6567         x(1)=dtan(theti)
6568         x(2)=alph(i)
6569         x(3)=omeg(i)
6570
6571         if (x(2).gt.pi-delta) then
6572           xtemp(1)=x(1)
6573           xtemp(2)=pi-delta
6574           xtemp(3)=x(3)
6575           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6576           xtemp(2)=pi
6577           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6578           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6579               escloci,dersc(2))
6580           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6581               ddersc0(1),dersc(1))
6582           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6583               ddersc0(3),dersc(3))
6584           xtemp(2)=pi-delta
6585           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6586           xtemp(2)=pi
6587           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6588           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6589                   dersc0(2),esclocbi,dersc02)
6590           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6591                   dersc12,dersc01)
6592           call splinthet(x(2),0.5d0*delta,ss,ssd)
6593           dersc0(1)=dersc01
6594           dersc0(2)=dersc02
6595           dersc0(3)=0.0d0
6596           do k=1,3
6597             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6598           enddo
6599           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6600 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6601 !    &             esclocbi,ss,ssd
6602           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6603 !         escloci=esclocbi
6604 !         write (iout,*) escloci
6605         else if (x(2).lt.delta) then
6606           xtemp(1)=x(1)
6607           xtemp(2)=delta
6608           xtemp(3)=x(3)
6609           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6610           xtemp(2)=0.0d0
6611           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6612           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6613               escloci,dersc(2))
6614           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6615               ddersc0(1),dersc(1))
6616           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6617               ddersc0(3),dersc(3))
6618           xtemp(2)=delta
6619           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6620           xtemp(2)=0.0d0
6621           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6622           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6623                   dersc0(2),esclocbi,dersc02)
6624           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6625                   dersc12,dersc01)
6626           dersc0(1)=dersc01
6627           dersc0(2)=dersc02
6628           dersc0(3)=0.0d0
6629           call splinthet(x(2),0.5d0*delta,ss,ssd)
6630           do k=1,3
6631             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6632           enddo
6633           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6634 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6635 !    &             esclocbi,ss,ssd
6636           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6637 !         write (iout,*) escloci
6638         else
6639           call enesc(x,escloci,dersc,ddummy,.false.)
6640         endif
6641
6642         escloc=escloc+escloci
6643         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6644            'escloc',i,escloci
6645 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6646
6647         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6648          wscloc*dersc(1)
6649         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6650         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6651     1   continue
6652       enddo
6653       return
6654       end subroutine esc
6655 !-----------------------------------------------------------------------------
6656       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6657
6658       use comm_sccalc
6659 !      implicit real*8 (a-h,o-z)
6660 !      include 'DIMENSIONS'
6661 !      include 'COMMON.GEO'
6662 !      include 'COMMON.LOCAL'
6663 !      include 'COMMON.IOUNITS'
6664 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6665       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6666       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6667       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6668       real(kind=8) :: escloci
6669       logical :: mixed
6670 !el local variables
6671       integer :: j,iii,l,k !el,it,nlobit
6672       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6673 !el       time11,time12,time112
6674 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6675         escloc_i=0.0D0
6676         do j=1,3
6677           dersc(j)=0.0D0
6678           if (mixed) ddersc(j)=0.0d0
6679         enddo
6680         x3=x(3)
6681
6682 ! Because of periodicity of the dependence of the SC energy in omega we have
6683 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6684 ! To avoid underflows, first compute & store the exponents.
6685
6686         do iii=-1,1
6687
6688           x(3)=x3+iii*dwapi
6689
6690           do j=1,nlobit
6691             do k=1,3
6692               z(k)=x(k)-censc(k,j,it)
6693             enddo
6694             do k=1,3
6695               Axk=0.0D0
6696               do l=1,3
6697                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6698               enddo
6699               Ax(k,j,iii)=Axk
6700             enddo
6701             expfac=0.0D0
6702             do k=1,3
6703               expfac=expfac+Ax(k,j,iii)*z(k)
6704             enddo
6705             contr(j,iii)=expfac
6706           enddo ! j
6707
6708         enddo ! iii
6709
6710         x(3)=x3
6711 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6712 ! subsequent NaNs and INFs in energy calculation.
6713 ! Find the largest exponent
6714         emin=contr(1,-1)
6715         do iii=-1,1
6716           do j=1,nlobit
6717             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6718           enddo
6719         enddo
6720         emin=0.5D0*emin
6721 !d      print *,'it=',it,' emin=',emin
6722
6723 ! Compute the contribution to SC energy and derivatives
6724         do iii=-1,1
6725
6726           do j=1,nlobit
6727 #ifdef OSF
6728             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6729             if(adexp.ne.adexp) adexp=1.0
6730             expfac=dexp(adexp)
6731 #else
6732             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6733 #endif
6734 !d          print *,'j=',j,' expfac=',expfac
6735             escloc_i=escloc_i+expfac
6736             do k=1,3
6737               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6738             enddo
6739             if (mixed) then
6740               do k=1,3,2
6741                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6742                   +gaussc(k,2,j,it))*expfac
6743               enddo
6744             endif
6745           enddo
6746
6747         enddo ! iii
6748
6749         dersc(1)=dersc(1)/cos(theti)**2
6750         ddersc(1)=ddersc(1)/cos(theti)**2
6751         ddersc(3)=ddersc(3)
6752
6753         escloci=-(dlog(escloc_i)-emin)
6754         do j=1,3
6755           dersc(j)=dersc(j)/escloc_i
6756         enddo
6757         if (mixed) then
6758           do j=1,3,2
6759             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6760           enddo
6761         endif
6762       return
6763       end subroutine enesc
6764 !-----------------------------------------------------------------------------
6765       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6766
6767       use comm_sccalc
6768 !      implicit real*8 (a-h,o-z)
6769 !      include 'DIMENSIONS'
6770 !      include 'COMMON.GEO'
6771 !      include 'COMMON.LOCAL'
6772 !      include 'COMMON.IOUNITS'
6773 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6774       real(kind=8),dimension(3) :: x,z,dersc
6775       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6776       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6777       real(kind=8) :: escloci,dersc12,emin
6778       logical :: mixed
6779 !el local varables
6780       integer :: j,k,l !el,it,nlobit
6781       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6782
6783       escloc_i=0.0D0
6784
6785       do j=1,3
6786         dersc(j)=0.0D0
6787       enddo
6788
6789       do j=1,nlobit
6790         do k=1,2
6791           z(k)=x(k)-censc(k,j,it)
6792         enddo
6793         z(3)=dwapi
6794         do k=1,3
6795           Axk=0.0D0
6796           do l=1,3
6797             Axk=Axk+gaussc(l,k,j,it)*z(l)
6798           enddo
6799           Ax(k,j)=Axk
6800         enddo
6801         expfac=0.0D0
6802         do k=1,3
6803           expfac=expfac+Ax(k,j)*z(k)
6804         enddo
6805         contr(j)=expfac
6806       enddo ! j
6807
6808 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6809 ! subsequent NaNs and INFs in energy calculation.
6810 ! Find the largest exponent
6811       emin=contr(1)
6812       do j=1,nlobit
6813         if (emin.gt.contr(j)) emin=contr(j)
6814       enddo
6815       emin=0.5D0*emin
6816
6817 ! Compute the contribution to SC energy and derivatives
6818
6819       dersc12=0.0d0
6820       do j=1,nlobit
6821         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6822         escloc_i=escloc_i+expfac
6823         do k=1,2
6824           dersc(k)=dersc(k)+Ax(k,j)*expfac
6825         enddo
6826         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6827                   +gaussc(1,2,j,it))*expfac
6828         dersc(3)=0.0d0
6829       enddo
6830
6831       dersc(1)=dersc(1)/cos(theti)**2
6832       dersc12=dersc12/cos(theti)**2
6833       escloci=-(dlog(escloc_i)-emin)
6834       do j=1,2
6835         dersc(j)=dersc(j)/escloc_i
6836       enddo
6837       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6838       return
6839       end subroutine enesc_bound
6840 #else
6841 !-----------------------------------------------------------------------------
6842       subroutine esc(escloc)
6843 ! Calculate the local energy of a side chain and its derivatives in the
6844 ! corresponding virtual-bond valence angles THETA and the spherical angles
6845 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6846 ! added by Urszula Kozlowska. 07/11/2007
6847 !
6848       use comm_sccalc
6849 !      implicit real*8 (a-h,o-z)
6850 !      include 'DIMENSIONS'
6851 !      include 'COMMON.GEO'
6852 !      include 'COMMON.LOCAL'
6853 !      include 'COMMON.VAR'
6854 !      include 'COMMON.SCROT'
6855 !      include 'COMMON.INTERACT'
6856 !      include 'COMMON.DERIV'
6857 !      include 'COMMON.CHAIN'
6858 !      include 'COMMON.IOUNITS'
6859 !      include 'COMMON.NAMES'
6860 !      include 'COMMON.FFIELD'
6861 !      include 'COMMON.CONTROL'
6862 !      include 'COMMON.VECTORS'
6863       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6864       real(kind=8),dimension(65) :: x
6865       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6866          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6867       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6868       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6869          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6870 !el local variables
6871       integer :: i,j,k !el,it,nlobit
6872       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6873 !el      real(kind=8) :: time11,time12,time112,theti
6874 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6875       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6876                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6877                    sumene1x,sumene2x,sumene3x,sumene4x,&
6878                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6879                    cosfac2xx,sinfac2yy
6880 #ifdef DEBUG
6881       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6882                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6883                    de_dt_num
6884 #endif
6885 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6886
6887       delta=0.02d0*pi
6888       escloc=0.0D0
6889       do i=loc_start,loc_end
6890         if (itype(i,1).eq.ntyp1) cycle
6891         costtab(i+1) =dcos(theta(i+1))
6892         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6893         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6894         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6895         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6896         cosfac=dsqrt(cosfac2)
6897         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6898         sinfac=dsqrt(sinfac2)
6899         it=iabs(itype(i,1))
6900         if (it.eq.10) goto 1
6901 !
6902 !  Compute the axes of tghe local cartesian coordinates system; store in
6903 !   x_prime, y_prime and z_prime
6904 !
6905         do j=1,3
6906           x_prime(j) = 0.00
6907           y_prime(j) = 0.00
6908           z_prime(j) = 0.00
6909         enddo
6910 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6911 !     &   dc_norm(3,i+nres)
6912         do j = 1,3
6913           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6914           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6915         enddo
6916         do j = 1,3
6917           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6918         enddo
6919 !       write (2,*) "i",i
6920 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6921 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6922 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6923 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6924 !      & " xy",scalar(x_prime(1),y_prime(1)),
6925 !      & " xz",scalar(x_prime(1),z_prime(1)),
6926 !      & " yy",scalar(y_prime(1),y_prime(1)),
6927 !      & " yz",scalar(y_prime(1),z_prime(1)),
6928 !      & " zz",scalar(z_prime(1),z_prime(1))
6929 !
6930 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6931 ! to local coordinate system. Store in xx, yy, zz.
6932 !
6933         xx=0.0d0
6934         yy=0.0d0
6935         zz=0.0d0
6936         do j = 1,3
6937           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6938           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6939           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6940         enddo
6941
6942         xxtab(i)=xx
6943         yytab(i)=yy
6944         zztab(i)=zz
6945 !
6946 ! Compute the energy of the ith side cbain
6947 !
6948 !        write (2,*) "xx",xx," yy",yy," zz",zz
6949         it=iabs(itype(i,1))
6950         do j = 1,65
6951           x(j) = sc_parmin(j,it)
6952         enddo
6953 #ifdef CHECK_COORD
6954 !c diagnostics - remove later
6955         xx1 = dcos(alph(2))
6956         yy1 = dsin(alph(2))*dcos(omeg(2))
6957         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6958         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6959           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6960           xx1,yy1,zz1
6961 !,"  --- ", xx_w,yy_w,zz_w
6962 ! end diagnostics
6963 #endif
6964         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6965          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6966          + x(10)*yy*zz
6967         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6968          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6969          + x(20)*yy*zz
6970         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6971          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6972          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6973          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6974          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6975          +x(40)*xx*yy*zz
6976         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6977          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6978          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6979          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6980          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6981          +x(60)*xx*yy*zz
6982         dsc_i   = 0.743d0+x(61)
6983         dp2_i   = 1.9d0+x(62)
6984         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6985                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6986         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6987                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6988         s1=(1+x(63))/(0.1d0 + dscp1)
6989         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6990         s2=(1+x(65))/(0.1d0 + dscp2)
6991         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6992         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6993       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6994 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6995 !     &   sumene4,
6996 !     &   dscp1,dscp2,sumene
6997 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6998         escloc = escloc + sumene
6999        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
7000         " escloc",sumene,escloc,it,itype(i,1)
7001 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
7002 !     & ,zz,xx,yy
7003 !#define DEBUG
7004 #ifdef DEBUG
7005 !
7006 ! This section to check the numerical derivatives of the energy of ith side
7007 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7008 ! #define DEBUG in the code to turn it on.
7009 !
7010         write (2,*) "sumene               =",sumene
7011         aincr=1.0d-7
7012         xxsave=xx
7013         xx=xx+aincr
7014         write (2,*) xx,yy,zz
7015         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7016         de_dxx_num=(sumenep-sumene)/aincr
7017         xx=xxsave
7018         write (2,*) "xx+ sumene from enesc=",sumenep
7019         yysave=yy
7020         yy=yy+aincr
7021         write (2,*) xx,yy,zz
7022         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7023         de_dyy_num=(sumenep-sumene)/aincr
7024         yy=yysave
7025         write (2,*) "yy+ sumene from enesc=",sumenep
7026         zzsave=zz
7027         zz=zz+aincr
7028         write (2,*) xx,yy,zz
7029         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7030         de_dzz_num=(sumenep-sumene)/aincr
7031         zz=zzsave
7032         write (2,*) "zz+ sumene from enesc=",sumenep
7033         costsave=cost2tab(i+1)
7034         sintsave=sint2tab(i+1)
7035         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7036         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7037         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7038         de_dt_num=(sumenep-sumene)/aincr
7039         write (2,*) " t+ sumene from enesc=",sumenep
7040         cost2tab(i+1)=costsave
7041         sint2tab(i+1)=sintsave
7042 ! End of diagnostics section.
7043 #endif
7044 !
7045 ! Compute the gradient of esc
7046 !
7047 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
7048         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7049         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7050         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7051         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7052         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7053         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7054         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7055         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7056         pom1=(sumene3*sint2tab(i+1)+sumene1) &
7057            *(pom_s1/dscp1+pom_s16*dscp1**4)
7058         pom2=(sumene4*cost2tab(i+1)+sumene2) &
7059            *(pom_s2/dscp2+pom_s26*dscp2**4)
7060         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7061         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
7062         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
7063         +x(40)*yy*zz
7064         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7065         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
7066         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
7067         +x(60)*yy*zz
7068         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
7069               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
7070               +(pom1+pom2)*pom_dx
7071 #ifdef DEBUG
7072         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
7073 #endif
7074 !
7075         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7076         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
7077         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
7078         +x(40)*xx*zz
7079         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7080         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
7081         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
7082         +x(59)*zz**2 +x(60)*xx*zz
7083         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
7084               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
7085               +(pom1-pom2)*pom_dy
7086 #ifdef DEBUG
7087         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
7088 #endif
7089 !
7090         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
7091         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
7092         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
7093         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
7094         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
7095         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
7096         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
7097         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7098 #ifdef DEBUG
7099         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
7100 #endif
7101 !
7102         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
7103         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
7104         +pom1*pom_dt1+pom2*pom_dt2
7105 #ifdef DEBUG
7106         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
7107 #endif
7108 !
7109 !
7110        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7111        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7112        cosfac2xx=cosfac2*xx
7113        sinfac2yy=sinfac2*yy
7114        do k = 1,3
7115          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
7116             vbld_inv(i+1)
7117          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
7118             vbld_inv(i)
7119          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7120          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7121 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7122 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7123 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7124 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7125          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7126          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7127          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7128          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7129          dZZ_Ci1(k)=0.0d0
7130          dZZ_Ci(k)=0.0d0
7131          do j=1,3
7132            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
7133            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7134            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
7135            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
7136          enddo
7137
7138          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7139          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7140          dZZ_XYZ(k)=vbld_inv(i+nres)* &
7141          (z_prime(k)-zz*dC_norm(k,i+nres))
7142 !
7143          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7144          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7145        enddo
7146
7147        do k=1,3
7148          dXX_Ctab(k,i)=dXX_Ci(k)
7149          dXX_C1tab(k,i)=dXX_Ci1(k)
7150          dYY_Ctab(k,i)=dYY_Ci(k)
7151          dYY_C1tab(k,i)=dYY_Ci1(k)
7152          dZZ_Ctab(k,i)=dZZ_Ci(k)
7153          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7154          dXX_XYZtab(k,i)=dXX_XYZ(k)
7155          dYY_XYZtab(k,i)=dYY_XYZ(k)
7156          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7157        enddo
7158
7159        do k = 1,3
7160 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7161 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7162 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7163 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7164 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7165 !     &    dt_dci(k)
7166 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7167 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7168          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
7169           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7170          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
7171           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7172          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
7173           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7174        enddo
7175 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7176 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7177
7178 ! to check gradient call subroutine check_grad
7179
7180     1 continue
7181       enddo
7182       return
7183       end subroutine esc
7184 !-----------------------------------------------------------------------------
7185       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7186 !      implicit none
7187       real(kind=8),dimension(65) :: x
7188       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7189         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7190
7191       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7192         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7193         + x(10)*yy*zz
7194       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7195         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7196         + x(20)*yy*zz
7197       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7198         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7199         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7200         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7201         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7202         +x(40)*xx*yy*zz
7203       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7204         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7205         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7206         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7207         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7208         +x(60)*xx*yy*zz
7209       dsc_i   = 0.743d0+x(61)
7210       dp2_i   = 1.9d0+x(62)
7211       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7212                 *(xx*cost2+yy*sint2))
7213       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7214                 *(xx*cost2-yy*sint2))
7215       s1=(1+x(63))/(0.1d0 + dscp1)
7216       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7217       s2=(1+x(65))/(0.1d0 + dscp2)
7218       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7219       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7220        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7221       enesc=sumene
7222       return
7223       end function enesc
7224 #endif
7225 !-----------------------------------------------------------------------------
7226       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7227 !
7228 ! This procedure calculates two-body contact function g(rij) and its derivative:
7229 !
7230 !           eps0ij                                     !       x < -1
7231 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7232 !            0                                         !       x > 1
7233 !
7234 ! where x=(rij-r0ij)/delta
7235 !
7236 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7237 !
7238 !      implicit none
7239       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7240       real(kind=8) :: x,x2,x4,delta
7241 !     delta=0.02D0*r0ij
7242 !      delta=0.2D0*r0ij
7243       x=(rij-r0ij)/delta
7244       if (x.lt.-1.0D0) then
7245         fcont=eps0ij
7246         fprimcont=0.0D0
7247       else if (x.le.1.0D0) then
7248         x2=x*x
7249         x4=x2*x2
7250         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7251         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7252       else
7253         fcont=0.0D0
7254         fprimcont=0.0D0
7255       endif
7256       return
7257       end subroutine gcont
7258 !-----------------------------------------------------------------------------
7259       subroutine splinthet(theti,delta,ss,ssder)
7260 !      implicit real*8 (a-h,o-z)
7261 !      include 'DIMENSIONS'
7262 !      include 'COMMON.VAR'
7263 !      include 'COMMON.GEO'
7264       real(kind=8) :: theti,delta,ss,ssder
7265       real(kind=8) :: thetup,thetlow
7266       thetup=pi-delta
7267       thetlow=delta
7268       if (theti.gt.pipol) then
7269         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7270       else
7271         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7272         ssder=-ssder
7273       endif
7274       return
7275       end subroutine splinthet
7276 !-----------------------------------------------------------------------------
7277       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7278 !      implicit none
7279       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7280       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7281       a1=fprim0*delta/(f1-f0)
7282       a2=3.0d0-2.0d0*a1
7283       a3=a1-2.0d0
7284       ksi=(x-x0)/delta
7285       ksi2=ksi*ksi
7286       ksi3=ksi2*ksi
7287       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7288       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7289       return
7290       end subroutine spline1
7291 !-----------------------------------------------------------------------------
7292       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7293 !      implicit none
7294       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7295       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7296       ksi=(x-x0)/delta
7297       ksi2=ksi*ksi
7298       ksi3=ksi2*ksi
7299       a1=fprim0x*delta
7300       a2=3*(f1x-f0x)-2*fprim0x*delta
7301       a3=fprim0x*delta-2*(f1x-f0x)
7302       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7303       return
7304       end subroutine spline2
7305 !-----------------------------------------------------------------------------
7306 #ifdef CRYST_TOR
7307 !-----------------------------------------------------------------------------
7308       subroutine etor(etors,edihcnstr)
7309 !      implicit real*8 (a-h,o-z)
7310 !      include 'DIMENSIONS'
7311 !      include 'COMMON.VAR'
7312 !      include 'COMMON.GEO'
7313 !      include 'COMMON.LOCAL'
7314 !      include 'COMMON.TORSION'
7315 !      include 'COMMON.INTERACT'
7316 !      include 'COMMON.DERIV'
7317 !      include 'COMMON.CHAIN'
7318 !      include 'COMMON.NAMES'
7319 !      include 'COMMON.IOUNITS'
7320 !      include 'COMMON.FFIELD'
7321 !      include 'COMMON.TORCNSTR'
7322 !      include 'COMMON.CONTROL'
7323       real(kind=8) :: etors,edihcnstr
7324       logical :: lprn
7325 !el local variables
7326       integer :: i,j,
7327       real(kind=8) :: phii,fac,etors_ii
7328
7329 ! Set lprn=.true. for debugging
7330       lprn=.false.
7331 !      lprn=.true.
7332       etors=0.0D0
7333       do i=iphi_start,iphi_end
7334       etors_ii=0.0D0
7335         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7336             .or. itype(i,1).eq.ntyp1) cycle
7337         itori=itortyp(itype(i-2,1))
7338         itori1=itortyp(itype(i-1,1))
7339         phii=phi(i)
7340         gloci=0.0D0
7341 ! Proline-Proline pair is a special case...
7342         if (itori.eq.3 .and. itori1.eq.3) then
7343           if (phii.gt.-dwapi3) then
7344             cosphi=dcos(3*phii)
7345             fac=1.0D0/(1.0D0-cosphi)
7346             etorsi=v1(1,3,3)*fac
7347             etorsi=etorsi+etorsi
7348             etors=etors+etorsi-v1(1,3,3)
7349             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7350             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7351           endif
7352           do j=1,3
7353             v1ij=v1(j+1,itori,itori1)
7354             v2ij=v2(j+1,itori,itori1)
7355             cosphi=dcos(j*phii)
7356             sinphi=dsin(j*phii)
7357             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7358             if (energy_dec) etors_ii=etors_ii+ &
7359                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7360             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7361           enddo
7362         else
7363           do j=1,nterm_old
7364             v1ij=v1(j,itori,itori1)
7365             v2ij=v2(j,itori,itori1)
7366             cosphi=dcos(j*phii)
7367             sinphi=dsin(j*phii)
7368             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7369             if (energy_dec) etors_ii=etors_ii+ &
7370                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7371             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7372           enddo
7373         endif
7374         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7375              'etor',i,etors_ii
7376         if (lprn) &
7377         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7378         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7379         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7380         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7381 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7382       enddo
7383 ! 6/20/98 - dihedral angle constraints
7384       edihcnstr=0.0d0
7385       do i=1,ndih_constr
7386         itori=idih_constr(i)
7387         phii=phi(itori)
7388         difi=phii-phi0(i)
7389         if (difi.gt.drange(i)) then
7390           difi=difi-drange(i)
7391           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7392           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7393         else if (difi.lt.-drange(i)) then
7394           difi=difi+drange(i)
7395           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7396           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7397         endif
7398 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7399 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7400       enddo
7401 !      write (iout,*) 'edihcnstr',edihcnstr
7402       return
7403       end subroutine etor
7404 !-----------------------------------------------------------------------------
7405       subroutine etor_d(etors_d)
7406       real(kind=8) :: etors_d
7407       etors_d=0.0d0
7408       return
7409       end subroutine etor_d
7410 #else
7411 !-----------------------------------------------------------------------------
7412       subroutine etor(etors)
7413 !      implicit real*8 (a-h,o-z)
7414 !      include 'DIMENSIONS'
7415 !      include 'COMMON.VAR'
7416 !      include 'COMMON.GEO'
7417 !      include 'COMMON.LOCAL'
7418 !      include 'COMMON.TORSION'
7419 !      include 'COMMON.INTERACT'
7420 !      include 'COMMON.DERIV'
7421 !      include 'COMMON.CHAIN'
7422 !      include 'COMMON.NAMES'
7423 !      include 'COMMON.IOUNITS'
7424 !      include 'COMMON.FFIELD'
7425 !      include 'COMMON.TORCNSTR'
7426 !      include 'COMMON.CONTROL'
7427       real(kind=8) :: etors,edihcnstr
7428       logical :: lprn
7429 !el local variables
7430       integer :: i,j,iblock,itori,itori1
7431       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7432                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7433 ! Set lprn=.true. for debugging
7434       lprn=.false.
7435 !     lprn=.true.
7436       etors=0.0D0
7437       do i=iphi_start,iphi_end
7438         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7439              .or. itype(i-3,1).eq.ntyp1 &
7440              .or. itype(i,1).eq.ntyp1) cycle
7441         etors_ii=0.0D0
7442          if (iabs(itype(i,1)).eq.20) then
7443          iblock=2
7444          else
7445          iblock=1
7446          endif
7447         itori=itortyp(itype(i-2,1))
7448         itori1=itortyp(itype(i-1,1))
7449         phii=phi(i)
7450         gloci=0.0D0
7451 ! Regular cosine and sine terms
7452         do j=1,nterm(itori,itori1,iblock)
7453           v1ij=v1(j,itori,itori1,iblock)
7454           v2ij=v2(j,itori,itori1,iblock)
7455           cosphi=dcos(j*phii)
7456           sinphi=dsin(j*phii)
7457           etors=etors+v1ij*cosphi+v2ij*sinphi
7458           if (energy_dec) etors_ii=etors_ii+ &
7459                      v1ij*cosphi+v2ij*sinphi
7460           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7461         enddo
7462 ! Lorentz terms
7463 !                         v1
7464 !  E = SUM ----------------------------------- - v1
7465 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7466 !
7467         cosphi=dcos(0.5d0*phii)
7468         sinphi=dsin(0.5d0*phii)
7469         do j=1,nlor(itori,itori1,iblock)
7470           vl1ij=vlor1(j,itori,itori1)
7471           vl2ij=vlor2(j,itori,itori1)
7472           vl3ij=vlor3(j,itori,itori1)
7473           pom=vl2ij*cosphi+vl3ij*sinphi
7474           pom1=1.0d0/(pom*pom+1.0d0)
7475           etors=etors+vl1ij*pom1
7476           if (energy_dec) etors_ii=etors_ii+ &
7477                      vl1ij*pom1
7478           pom=-pom*pom1*pom1
7479           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7480         enddo
7481 ! Subtract the constant term
7482         etors=etors-v0(itori,itori1,iblock)
7483           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7484                'etor',i,etors_ii-v0(itori,itori1,iblock)
7485         if (lprn) &
7486         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7487         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7488         (v1(j,itori,itori1,iblock),j=1,6),&
7489         (v2(j,itori,itori1,iblock),j=1,6)
7490         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7491 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7492       enddo
7493 ! 6/20/98 - dihedral angle constraints
7494       return
7495       end subroutine etor
7496 !C The rigorous attempt to derive energy function
7497 !-------------------------------------------------------------------------------------------
7498       subroutine etor_kcc(etors)
7499       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7500       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7501        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7502        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7503        gradvalst2,etori
7504       logical lprn
7505       integer :: i,j,itori,itori1,nval,k,l
7506
7507       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7508       etors=0.0D0
7509       do i=iphi_start,iphi_end
7510 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7511 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7512 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7513 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7514         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7515            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7516         itori=itortyp(itype(i-2,1))
7517         itori1=itortyp(itype(i-1,1))
7518         phii=phi(i)
7519         glocig=0.0D0
7520         glocit1=0.0d0
7521         glocit2=0.0d0
7522 !C to avoid multiple devision by 2
7523 !c        theti22=0.5d0*theta(i)
7524 !C theta 12 is the theta_1 /2
7525 !C theta 22 is theta_2 /2
7526 !c        theti12=0.5d0*theta(i-1)
7527 !C and appropriate sinus function
7528         sinthet1=dsin(theta(i-1))
7529         sinthet2=dsin(theta(i))
7530         costhet1=dcos(theta(i-1))
7531         costhet2=dcos(theta(i))
7532 !C to speed up lets store its mutliplication
7533         sint1t2=sinthet2*sinthet1
7534         sint1t2n=1.0d0
7535 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7536 !C +d_n*sin(n*gamma)) *
7537 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7538 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7539         nval=nterm_kcc_Tb(itori,itori1)
7540         c1(0)=0.0d0
7541         c2(0)=0.0d0
7542         c1(1)=1.0d0
7543         c2(1)=1.0d0
7544         do j=2,nval
7545           c1(j)=c1(j-1)*costhet1
7546           c2(j)=c2(j-1)*costhet2
7547         enddo
7548         etori=0.0d0
7549
7550        do j=1,nterm_kcc(itori,itori1)
7551           cosphi=dcos(j*phii)
7552           sinphi=dsin(j*phii)
7553           sint1t2n1=sint1t2n
7554           sint1t2n=sint1t2n*sint1t2
7555           sumvalc=0.0d0
7556           gradvalct1=0.0d0
7557           gradvalct2=0.0d0
7558           do k=1,nval
7559             do l=1,nval
7560               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7561               gradvalct1=gradvalct1+ &
7562                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7563               gradvalct2=gradvalct2+ &
7564                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7565             enddo
7566           enddo
7567           gradvalct1=-gradvalct1*sinthet1
7568           gradvalct2=-gradvalct2*sinthet2
7569           sumvals=0.0d0
7570           gradvalst1=0.0d0
7571           gradvalst2=0.0d0
7572           do k=1,nval
7573             do l=1,nval
7574               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7575               gradvalst1=gradvalst1+ &
7576                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7577               gradvalst2=gradvalst2+ &
7578                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7579             enddo
7580           enddo
7581           gradvalst1=-gradvalst1*sinthet1
7582           gradvalst2=-gradvalst2*sinthet2
7583           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7584           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7585 !C glocig is the gradient local i site in gamma
7586           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7587 !C now gradient over theta_1
7588          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7589         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7590          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7591         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7592         enddo ! j
7593         etors=etors+etori
7594         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7595 !C derivative over theta1
7596         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7597 !C now derivative over theta2
7598         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7599         if (lprn) then
7600          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7601             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7602           write (iout,*) "c1",(c1(k),k=0,nval), &
7603          " c2",(c2(k),k=0,nval)
7604         endif
7605       enddo
7606       return
7607        end  subroutine etor_kcc
7608 !------------------------------------------------------------------------------
7609
7610         subroutine etor_constr(edihcnstr)
7611       real(kind=8) :: etors,edihcnstr
7612       logical :: lprn
7613 !el local variables
7614       integer :: i,j,iblock,itori,itori1
7615       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7616                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7617                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7618
7619       if (raw_psipred) then
7620         do i=idihconstr_start,idihconstr_end
7621           itori=idih_constr(i)
7622           phii=phi(itori)
7623           gaudih_i=vpsipred(1,i)
7624           gauder_i=0.0d0
7625           do j=1,2
7626             s = sdihed(j,i)
7627             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7628             dexpcos_i=dexp(-cos_i*cos_i)
7629             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7630           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7631                  *cos_i*dexpcos_i/s**2
7632           enddo
7633           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7634           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7635           if (energy_dec) &
7636           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7637           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7638           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7639           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7640           -wdihc*dlog(gaudih_i)
7641         enddo
7642       else
7643
7644       do i=idihconstr_start,idihconstr_end
7645         itori=idih_constr(i)
7646         phii=phi(itori)
7647         difi=pinorm(phii-phi0(i))
7648         if (difi.gt.drange(i)) then
7649           difi=difi-drange(i)
7650           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7651           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7652         else if (difi.lt.-drange(i)) then
7653           difi=difi+drange(i)
7654           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7655           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7656         else
7657           difi=0.0
7658         endif
7659       enddo
7660
7661       endif
7662
7663       return
7664
7665       end subroutine etor_constr
7666 !-----------------------------------------------------------------------------
7667       subroutine etor_d(etors_d)
7668 ! 6/23/01 Compute double torsional energy
7669 !      implicit real*8 (a-h,o-z)
7670 !      include 'DIMENSIONS'
7671 !      include 'COMMON.VAR'
7672 !      include 'COMMON.GEO'
7673 !      include 'COMMON.LOCAL'
7674 !      include 'COMMON.TORSION'
7675 !      include 'COMMON.INTERACT'
7676 !      include 'COMMON.DERIV'
7677 !      include 'COMMON.CHAIN'
7678 !      include 'COMMON.NAMES'
7679 !      include 'COMMON.IOUNITS'
7680 !      include 'COMMON.FFIELD'
7681 !      include 'COMMON.TORCNSTR'
7682       real(kind=8) :: etors_d,etors_d_ii
7683       logical :: lprn
7684 !el local variables
7685       integer :: i,j,k,l,itori,itori1,itori2,iblock
7686       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7687                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7688                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7689                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7690 ! Set lprn=.true. for debugging
7691       lprn=.false.
7692 !     lprn=.true.
7693       etors_d=0.0D0
7694 !      write(iout,*) "a tu??"
7695       do i=iphid_start,iphid_end
7696         etors_d_ii=0.0D0
7697         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7698             .or. itype(i-3,1).eq.ntyp1 &
7699             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7700         itori=itortyp(itype(i-2,1))
7701         itori1=itortyp(itype(i-1,1))
7702         itori2=itortyp(itype(i,1))
7703         phii=phi(i)
7704         phii1=phi(i+1)
7705         gloci1=0.0D0
7706         gloci2=0.0D0
7707         iblock=1
7708         if (iabs(itype(i+1,1)).eq.20) iblock=2
7709
7710 ! Regular cosine and sine terms
7711         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7712           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7713           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7714           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7715           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7716           cosphi1=dcos(j*phii)
7717           sinphi1=dsin(j*phii)
7718           cosphi2=dcos(j*phii1)
7719           sinphi2=dsin(j*phii1)
7720           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7721            v2cij*cosphi2+v2sij*sinphi2
7722           if (energy_dec) etors_d_ii=etors_d_ii+ &
7723            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7724           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7725           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7726         enddo
7727         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7728           do l=1,k-1
7729             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7730             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7731             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7732             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7733             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7734             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7735             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7736             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7737             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7738               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7739             if (energy_dec) etors_d_ii=etors_d_ii+ &
7740               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7741               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7742             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7743               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7744             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7745               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7746           enddo
7747         enddo
7748         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7749                             'etor_d',i,etors_d_ii
7750         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7751         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7752       enddo
7753       return
7754       end subroutine etor_d
7755 #endif
7756
7757       subroutine ebend_kcc(etheta)
7758       logical lprn
7759       double precision thybt1(maxang_kcc),etheta
7760       integer :: i,iti,j,ihelp
7761       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7762 !C Set lprn=.true. for debugging
7763       lprn=energy_dec
7764 !c     lprn=.true.
7765 !C      print *,"wchodze kcc"
7766       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7767       etheta=0.0D0
7768       do i=ithet_start,ithet_end
7769 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7770         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7771        .or.itype(i,1).eq.ntyp1) cycle
7772         iti=iabs(itortyp(itype(i-1,1)))
7773         sinthet=dsin(theta(i))
7774         costhet=dcos(theta(i))
7775         do j=1,nbend_kcc_Tb(iti)
7776           thybt1(j)=v1bend_chyb(j,iti)
7777         enddo
7778         sumth1thyb=v1bend_chyb(0,iti)+ &
7779          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7780         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7781          sumth1thyb
7782         ihelp=nbend_kcc_Tb(iti)-1
7783         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7784         etheta=etheta+sumth1thyb
7785 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7786         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7787       enddo
7788       return
7789       end subroutine ebend_kcc
7790 !c------------
7791 !c-------------------------------------------------------------------------------------
7792       subroutine etheta_constr(ethetacnstr)
7793       real (kind=8) :: ethetacnstr,thetiii,difi
7794       integer :: i,itheta
7795       ethetacnstr=0.0d0
7796 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7797       do i=ithetaconstr_start,ithetaconstr_end
7798         itheta=itheta_constr(i)
7799         thetiii=theta(itheta)
7800         difi=pinorm(thetiii-theta_constr0(i))
7801         if (difi.gt.theta_drange(i)) then
7802           difi=difi-theta_drange(i)
7803           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7804           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7805          +for_thet_constr(i)*difi**3
7806         else if (difi.lt.-drange(i)) then
7807           difi=difi+drange(i)
7808           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7809           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7810           +for_thet_constr(i)*difi**3
7811         else
7812           difi=0.0
7813         endif
7814        if (energy_dec) then
7815         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7816          i,itheta,rad2deg*thetiii,&
7817          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7818          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7819          gloc(itheta+nphi-2,icg)
7820         endif
7821       enddo
7822       return
7823       end subroutine etheta_constr
7824
7825 !-----------------------------------------------------------------------------
7826       subroutine eback_sc_corr(esccor)
7827 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7828 !        conformational states; temporarily implemented as differences
7829 !        between UNRES torsional potentials (dependent on three types of
7830 !        residues) and the torsional potentials dependent on all 20 types
7831 !        of residues computed from AM1  energy surfaces of terminally-blocked
7832 !        amino-acid residues.
7833 !      implicit real*8 (a-h,o-z)
7834 !      include 'DIMENSIONS'
7835 !      include 'COMMON.VAR'
7836 !      include 'COMMON.GEO'
7837 !      include 'COMMON.LOCAL'
7838 !      include 'COMMON.TORSION'
7839 !      include 'COMMON.SCCOR'
7840 !      include 'COMMON.INTERACT'
7841 !      include 'COMMON.DERIV'
7842 !      include 'COMMON.CHAIN'
7843 !      include 'COMMON.NAMES'
7844 !      include 'COMMON.IOUNITS'
7845 !      include 'COMMON.FFIELD'
7846 !      include 'COMMON.CONTROL'
7847       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7848                    cosphi,sinphi
7849       logical :: lprn
7850       integer :: i,interty,j,isccori,isccori1,intertyp
7851 ! Set lprn=.true. for debugging
7852       lprn=.false.
7853 !      lprn=.true.
7854 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7855       esccor=0.0D0
7856       do i=itau_start,itau_end
7857         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7858         esccor_ii=0.0D0
7859         isccori=isccortyp(itype(i-2,1))
7860         isccori1=isccortyp(itype(i-1,1))
7861
7862 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7863         phii=phi(i)
7864         do intertyp=1,3 !intertyp
7865          esccor_ii=0.0D0
7866 !c Added 09 May 2012 (Adasko)
7867 !c  Intertyp means interaction type of backbone mainchain correlation:
7868 !   1 = SC...Ca...Ca...Ca
7869 !   2 = Ca...Ca...Ca...SC
7870 !   3 = SC...Ca...Ca...SCi
7871         gloci=0.0D0
7872         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7873             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7874             (itype(i-1,1).eq.ntyp1))) &
7875           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7876            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7877            .or.(itype(i,1).eq.ntyp1))) &
7878           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7879             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7880             (itype(i-3,1).eq.ntyp1)))) cycle
7881         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7882         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7883        cycle
7884        do j=1,nterm_sccor(isccori,isccori1)
7885           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7886           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7887           cosphi=dcos(j*tauangle(intertyp,i))
7888           sinphi=dsin(j*tauangle(intertyp,i))
7889           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7890           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7891           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7892         enddo
7893         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7894                                 'esccor',i,intertyp,esccor_ii
7895 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7896         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7897         if (lprn) &
7898         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7899         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7900         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7901         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7902         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7903        enddo !intertyp
7904       enddo
7905
7906       return
7907       end subroutine eback_sc_corr
7908 !-----------------------------------------------------------------------------
7909       subroutine multibody(ecorr)
7910 ! This subroutine calculates multi-body contributions to energy following
7911 ! the idea of Skolnick et al. If side chains I and J make a contact and
7912 ! at the same time side chains I+1 and J+1 make a contact, an extra
7913 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7914 !      implicit real*8 (a-h,o-z)
7915 !      include 'DIMENSIONS'
7916 !      include 'COMMON.IOUNITS'
7917 !      include 'COMMON.DERIV'
7918 !      include 'COMMON.INTERACT'
7919 !      include 'COMMON.CONTACTS'
7920       real(kind=8),dimension(3) :: gx,gx1
7921       logical :: lprn
7922       real(kind=8) :: ecorr
7923       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7924 ! Set lprn=.true. for debugging
7925       lprn=.false.
7926
7927       if (lprn) then
7928         write (iout,'(a)') 'Contact function values:'
7929         do i=nnt,nct-2
7930           write (iout,'(i2,20(1x,i2,f10.5))') &
7931               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7932         enddo
7933       endif
7934       ecorr=0.0D0
7935
7936 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7937 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7938       do i=nnt,nct
7939         do j=1,3
7940           gradcorr(j,i)=0.0D0
7941           gradxorr(j,i)=0.0D0
7942         enddo
7943       enddo
7944       do i=nnt,nct-2
7945
7946         DO ISHIFT = 3,4
7947
7948         i1=i+ishift
7949         num_conti=num_cont(i)
7950         num_conti1=num_cont(i1)
7951         do jj=1,num_conti
7952           j=jcont(jj,i)
7953           do kk=1,num_conti1
7954             j1=jcont(kk,i1)
7955             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7956 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7957 !d   &                   ' ishift=',ishift
7958 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7959 ! The system gains extra energy.
7960               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7961             endif   ! j1==j+-ishift
7962           enddo     ! kk
7963         enddo       ! jj
7964
7965         ENDDO ! ISHIFT
7966
7967       enddo         ! i
7968       return
7969       end subroutine multibody
7970 !-----------------------------------------------------------------------------
7971       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7972 !      implicit real*8 (a-h,o-z)
7973 !      include 'DIMENSIONS'
7974 !      include 'COMMON.IOUNITS'
7975 !      include 'COMMON.DERIV'
7976 !      include 'COMMON.INTERACT'
7977 !      include 'COMMON.CONTACTS'
7978       real(kind=8),dimension(3) :: gx,gx1
7979       logical :: lprn
7980       integer :: i,j,k,l,jj,kk,m,ll
7981       real(kind=8) :: eij,ekl
7982       lprn=.false.
7983       eij=facont(jj,i)
7984       ekl=facont(kk,k)
7985 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7986 ! Calculate the multi-body contribution to energy.
7987 ! Calculate multi-body contributions to the gradient.
7988 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7989 !d   & k,l,(gacont(m,kk,k),m=1,3)
7990       do m=1,3
7991         gx(m) =ekl*gacont(m,jj,i)
7992         gx1(m)=eij*gacont(m,kk,k)
7993         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7994         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7995         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7996         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7997       enddo
7998       do m=i,j-1
7999         do ll=1,3
8000           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8001         enddo
8002       enddo
8003       do m=k,l-1
8004         do ll=1,3
8005           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8006         enddo
8007       enddo
8008       esccorr=-eij*ekl
8009       return
8010       end function esccorr
8011 !-----------------------------------------------------------------------------
8012       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8013 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8014 !      implicit real*8 (a-h,o-z)
8015 !      include 'DIMENSIONS'
8016 !      include 'COMMON.IOUNITS'
8017 #ifdef MPI
8018       include "mpif.h"
8019 !      integer :: maxconts !max_cont=maxconts  =nres/4
8020       integer,parameter :: max_dim=26
8021       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8022       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8023 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8024 !el      common /przechowalnia/ zapas
8025       integer :: status(MPI_STATUS_SIZE)
8026       integer,dimension((nres/4)*2) :: req !maxconts*2
8027       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
8028 #endif
8029 !      include 'COMMON.SETUP'
8030 !      include 'COMMON.FFIELD'
8031 !      include 'COMMON.DERIV'
8032 !      include 'COMMON.INTERACT'
8033 !      include 'COMMON.CONTACTS'
8034 !      include 'COMMON.CONTROL'
8035 !      include 'COMMON.LOCAL'
8036       real(kind=8),dimension(3) :: gx,gx1
8037       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
8038       logical :: lprn,ldone
8039 !el local variables
8040       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
8041               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
8042
8043 ! Set lprn=.true. for debugging
8044       lprn=.false.
8045 #ifdef MPI
8046 !      maxconts=nres/4
8047       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8048       n_corr=0
8049       n_corr1=0
8050       if (nfgtasks.le.1) goto 30
8051       if (lprn) then
8052         write (iout,'(a)') 'Contact function values before RECEIVE:'
8053         do i=nnt,nct-2
8054           write (iout,'(2i3,50(1x,i2,f5.2))') &
8055           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8056           j=1,num_cont_hb(i))
8057         enddo
8058       endif
8059       call flush(iout)
8060       do i=1,ntask_cont_from
8061         ncont_recv(i)=0
8062       enddo
8063       do i=1,ntask_cont_to
8064         ncont_sent(i)=0
8065       enddo
8066 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8067 !     & ntask_cont_to
8068 ! Make the list of contacts to send to send to other procesors
8069 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8070 !      call flush(iout)
8071       do i=iturn3_start,iturn3_end
8072 !        write (iout,*) "make contact list turn3",i," num_cont",
8073 !     &    num_cont_hb(i)
8074         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8075       enddo
8076       do i=iturn4_start,iturn4_end
8077 !        write (iout,*) "make contact list turn4",i," num_cont",
8078 !     &   num_cont_hb(i)
8079         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8080       enddo
8081       do ii=1,nat_sent
8082         i=iat_sent(ii)
8083 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8084 !     &    num_cont_hb(i)
8085         do j=1,num_cont_hb(i)
8086         do k=1,4
8087           jjc=jcont_hb(j,i)
8088           iproc=iint_sent_local(k,jjc,ii)
8089 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8090           if (iproc.gt.0) then
8091             ncont_sent(iproc)=ncont_sent(iproc)+1
8092             nn=ncont_sent(iproc)
8093             zapas(1,nn,iproc)=i
8094             zapas(2,nn,iproc)=jjc
8095             zapas(3,nn,iproc)=facont_hb(j,i)
8096             zapas(4,nn,iproc)=ees0p(j,i)
8097             zapas(5,nn,iproc)=ees0m(j,i)
8098             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8099             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8100             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8101             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8102             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8103             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8104             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8105             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8106             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8107             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8108             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8109             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8110             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8111             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8112             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8113             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8114             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8115             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8116             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8117             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8118             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8119           endif
8120         enddo
8121         enddo
8122       enddo
8123       if (lprn) then
8124       write (iout,*) &
8125         "Numbers of contacts to be sent to other processors",&
8126         (ncont_sent(i),i=1,ntask_cont_to)
8127       write (iout,*) "Contacts sent"
8128       do ii=1,ntask_cont_to
8129         nn=ncont_sent(ii)
8130         iproc=itask_cont_to(ii)
8131         write (iout,*) nn," contacts to processor",iproc,&
8132          " of CONT_TO_COMM group"
8133         do i=1,nn
8134           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8135         enddo
8136       enddo
8137       call flush(iout)
8138       endif
8139       CorrelType=477
8140       CorrelID=fg_rank+1
8141       CorrelType1=478
8142       CorrelID1=nfgtasks+fg_rank+1
8143       ireq=0
8144 ! Receive the numbers of needed contacts from other processors
8145       do ii=1,ntask_cont_from
8146         iproc=itask_cont_from(ii)
8147         ireq=ireq+1
8148         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8149           FG_COMM,req(ireq),IERR)
8150       enddo
8151 !      write (iout,*) "IRECV ended"
8152 !      call flush(iout)
8153 ! Send the number of contacts needed by other processors
8154       do ii=1,ntask_cont_to
8155         iproc=itask_cont_to(ii)
8156         ireq=ireq+1
8157         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8158           FG_COMM,req(ireq),IERR)
8159       enddo
8160 !      write (iout,*) "ISEND ended"
8161 !      write (iout,*) "number of requests (nn)",ireq
8162       call flush(iout)
8163       if (ireq.gt.0) &
8164         call MPI_Waitall(ireq,req,status_array,ierr)
8165 !      write (iout,*)
8166 !     &  "Numbers of contacts to be received from other processors",
8167 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8168 !      call flush(iout)
8169 ! Receive contacts
8170       ireq=0
8171       do ii=1,ntask_cont_from
8172         iproc=itask_cont_from(ii)
8173         nn=ncont_recv(ii)
8174 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8175 !     &   " of CONT_TO_COMM group"
8176         call flush(iout)
8177         if (nn.gt.0) then
8178           ireq=ireq+1
8179           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8180           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8181 !          write (iout,*) "ireq,req",ireq,req(ireq)
8182         endif
8183       enddo
8184 ! Send the contacts to processors that need them
8185       do ii=1,ntask_cont_to
8186         iproc=itask_cont_to(ii)
8187         nn=ncont_sent(ii)
8188 !        write (iout,*) nn," contacts to processor",iproc,
8189 !     &   " of CONT_TO_COMM group"
8190         if (nn.gt.0) then
8191           ireq=ireq+1
8192           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8193             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8194 !          write (iout,*) "ireq,req",ireq,req(ireq)
8195 !          do i=1,nn
8196 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8197 !          enddo
8198         endif
8199       enddo
8200 !      write (iout,*) "number of requests (contacts)",ireq
8201 !      write (iout,*) "req",(req(i),i=1,4)
8202 !      call flush(iout)
8203       if (ireq.gt.0) &
8204        call MPI_Waitall(ireq,req,status_array,ierr)
8205       do iii=1,ntask_cont_from
8206         iproc=itask_cont_from(iii)
8207         nn=ncont_recv(iii)
8208         if (lprn) then
8209         write (iout,*) "Received",nn," contacts from processor",iproc,&
8210          " of CONT_FROM_COMM group"
8211         call flush(iout)
8212         do i=1,nn
8213           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8214         enddo
8215         call flush(iout)
8216         endif
8217         do i=1,nn
8218           ii=zapas_recv(1,i,iii)
8219 ! Flag the received contacts to prevent double-counting
8220           jj=-zapas_recv(2,i,iii)
8221 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8222 !          call flush(iout)
8223           nnn=num_cont_hb(ii)+1
8224           num_cont_hb(ii)=nnn
8225           jcont_hb(nnn,ii)=jj
8226           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8227           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8228           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8229           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8230           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8231           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8232           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8233           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8234           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8235           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8236           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8237           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8238           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8239           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8240           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8241           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8242           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8243           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8244           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8245           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8246           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8247           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8248           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8249           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8250         enddo
8251       enddo
8252       call flush(iout)
8253       if (lprn) then
8254         write (iout,'(a)') 'Contact function values after receive:'
8255         do i=nnt,nct-2
8256           write (iout,'(2i3,50(1x,i3,f5.2))') &
8257           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8258           j=1,num_cont_hb(i))
8259         enddo
8260         call flush(iout)
8261       endif
8262    30 continue
8263 #endif
8264       if (lprn) then
8265         write (iout,'(a)') 'Contact function values:'
8266         do i=nnt,nct-2
8267           write (iout,'(2i3,50(1x,i3,f5.2))') &
8268           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8269           j=1,num_cont_hb(i))
8270         enddo
8271       endif
8272       ecorr=0.0D0
8273
8274 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8275 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8276 ! Remove the loop below after debugging !!!
8277       do i=nnt,nct
8278         do j=1,3
8279           gradcorr(j,i)=0.0D0
8280           gradxorr(j,i)=0.0D0
8281         enddo
8282       enddo
8283 ! Calculate the local-electrostatic correlation terms
8284       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8285         i1=i+1
8286         num_conti=num_cont_hb(i)
8287         num_conti1=num_cont_hb(i+1)
8288         do jj=1,num_conti
8289           j=jcont_hb(jj,i)
8290           jp=iabs(j)
8291           do kk=1,num_conti1
8292             j1=jcont_hb(kk,i1)
8293             jp1=iabs(j1)
8294 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8295 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8296             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8297                 .or. j.lt.0 .and. j1.gt.0) .and. &
8298                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8299 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8300 ! The system gains extra energy.
8301               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8302               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8303                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8304               n_corr=n_corr+1
8305             else if (j1.eq.j) then
8306 ! Contacts I-J and I-(J+1) occur simultaneously.
8307 ! The system loses extra energy.
8308 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8309             endif
8310           enddo ! kk
8311           do kk=1,num_conti
8312             j1=jcont_hb(kk,i)
8313 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8314 !    &         ' jj=',jj,' kk=',kk
8315             if (j1.eq.j+1) then
8316 ! Contacts I-J and (I+1)-J occur simultaneously.
8317 ! The system loses extra energy.
8318 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8319             endif ! j1==j+1
8320           enddo ! kk
8321         enddo ! jj
8322       enddo ! i
8323       return
8324       end subroutine multibody_hb
8325 !-----------------------------------------------------------------------------
8326       subroutine add_hb_contact(ii,jj,itask)
8327 !      implicit real*8 (a-h,o-z)
8328 !      include "DIMENSIONS"
8329 !      include "COMMON.IOUNITS"
8330 !      include "COMMON.CONTACTS"
8331 !      integer,parameter :: maxconts=nres/4
8332       integer,parameter :: max_dim=26
8333       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8334 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8335 !      common /przechowalnia/ zapas
8336       integer :: i,j,ii,jj,iproc,nn,jjc
8337       integer,dimension(4) :: itask
8338 !      write (iout,*) "itask",itask
8339       do i=1,2
8340         iproc=itask(i)
8341         if (iproc.gt.0) then
8342           do j=1,num_cont_hb(ii)
8343             jjc=jcont_hb(j,ii)
8344 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8345             if (jjc.eq.jj) then
8346               ncont_sent(iproc)=ncont_sent(iproc)+1
8347               nn=ncont_sent(iproc)
8348               zapas(1,nn,iproc)=ii
8349               zapas(2,nn,iproc)=jjc
8350               zapas(3,nn,iproc)=facont_hb(j,ii)
8351               zapas(4,nn,iproc)=ees0p(j,ii)
8352               zapas(5,nn,iproc)=ees0m(j,ii)
8353               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8354               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8355               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8356               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8357               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8358               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8359               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8360               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8361               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8362               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8363               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8364               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8365               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8366               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8367               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8368               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8369               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8370               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8371               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8372               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8373               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8374               exit
8375             endif
8376           enddo
8377         endif
8378       enddo
8379       return
8380       end subroutine add_hb_contact
8381 !-----------------------------------------------------------------------------
8382       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8383 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8384 !      implicit real*8 (a-h,o-z)
8385 !      include 'DIMENSIONS'
8386 !      include 'COMMON.IOUNITS'
8387       integer,parameter :: max_dim=70
8388 #ifdef MPI
8389       include "mpif.h"
8390 !      integer :: maxconts !max_cont=maxconts=nres/4
8391       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8392       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8393 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8394 !      common /przechowalnia/ zapas
8395       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8396         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8397         ierr,iii,nnn
8398 #endif
8399 !      include 'COMMON.SETUP'
8400 !      include 'COMMON.FFIELD'
8401 !      include 'COMMON.DERIV'
8402 !      include 'COMMON.LOCAL'
8403 !      include 'COMMON.INTERACT'
8404 !      include 'COMMON.CONTACTS'
8405 !      include 'COMMON.CHAIN'
8406 !      include 'COMMON.CONTROL'
8407       real(kind=8),dimension(3) :: gx,gx1
8408       integer,dimension(nres) :: num_cont_hb_old
8409       logical :: lprn,ldone
8410 !EL      double precision eello4,eello5,eelo6,eello_turn6
8411 !EL      external eello4,eello5,eello6,eello_turn6
8412 !el local variables
8413       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8414               j1,jp1,i1,num_conti1
8415       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8416       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8417
8418 ! Set lprn=.true. for debugging
8419       lprn=.false.
8420       eturn6=0.0d0
8421 #ifdef MPI
8422 !      maxconts=nres/4
8423       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8424       do i=1,nres
8425         num_cont_hb_old(i)=num_cont_hb(i)
8426       enddo
8427       n_corr=0
8428       n_corr1=0
8429       if (nfgtasks.le.1) goto 30
8430       if (lprn) then
8431         write (iout,'(a)') 'Contact function values before RECEIVE:'
8432         do i=nnt,nct-2
8433           write (iout,'(2i3,50(1x,i2,f5.2))') &
8434           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8435           j=1,num_cont_hb(i))
8436         enddo
8437       endif
8438       call flush(iout)
8439       do i=1,ntask_cont_from
8440         ncont_recv(i)=0
8441       enddo
8442       do i=1,ntask_cont_to
8443         ncont_sent(i)=0
8444       enddo
8445 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8446 !     & ntask_cont_to
8447 ! Make the list of contacts to send to send to other procesors
8448       do i=iturn3_start,iturn3_end
8449 !        write (iout,*) "make contact list turn3",i," num_cont",
8450 !     &    num_cont_hb(i)
8451         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8452       enddo
8453       do i=iturn4_start,iturn4_end
8454 !        write (iout,*) "make contact list turn4",i," num_cont",
8455 !     &   num_cont_hb(i)
8456         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8457       enddo
8458       do ii=1,nat_sent
8459         i=iat_sent(ii)
8460 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8461 !     &    num_cont_hb(i)
8462         do j=1,num_cont_hb(i)
8463         do k=1,4
8464           jjc=jcont_hb(j,i)
8465           iproc=iint_sent_local(k,jjc,ii)
8466 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8467           if (iproc.ne.0) then
8468             ncont_sent(iproc)=ncont_sent(iproc)+1
8469             nn=ncont_sent(iproc)
8470             zapas(1,nn,iproc)=i
8471             zapas(2,nn,iproc)=jjc
8472             zapas(3,nn,iproc)=d_cont(j,i)
8473             ind=3
8474             do kk=1,3
8475               ind=ind+1
8476               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8477             enddo
8478             do kk=1,2
8479               do ll=1,2
8480                 ind=ind+1
8481                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8482               enddo
8483             enddo
8484             do jj=1,5
8485               do kk=1,3
8486                 do ll=1,2
8487                   do mm=1,2
8488                     ind=ind+1
8489                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8490                   enddo
8491                 enddo
8492               enddo
8493             enddo
8494           endif
8495         enddo
8496         enddo
8497       enddo
8498       if (lprn) then
8499       write (iout,*) &
8500         "Numbers of contacts to be sent to other processors",&
8501         (ncont_sent(i),i=1,ntask_cont_to)
8502       write (iout,*) "Contacts sent"
8503       do ii=1,ntask_cont_to
8504         nn=ncont_sent(ii)
8505         iproc=itask_cont_to(ii)
8506         write (iout,*) nn," contacts to processor",iproc,&
8507          " of CONT_TO_COMM group"
8508         do i=1,nn
8509           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8510         enddo
8511       enddo
8512       call flush(iout)
8513       endif
8514       CorrelType=477
8515       CorrelID=fg_rank+1
8516       CorrelType1=478
8517       CorrelID1=nfgtasks+fg_rank+1
8518       ireq=0
8519 ! Receive the numbers of needed contacts from other processors
8520       do ii=1,ntask_cont_from
8521         iproc=itask_cont_from(ii)
8522         ireq=ireq+1
8523         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8524           FG_COMM,req(ireq),IERR)
8525       enddo
8526 !      write (iout,*) "IRECV ended"
8527 !      call flush(iout)
8528 ! Send the number of contacts needed by other processors
8529       do ii=1,ntask_cont_to
8530         iproc=itask_cont_to(ii)
8531         ireq=ireq+1
8532         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8533           FG_COMM,req(ireq),IERR)
8534       enddo
8535 !      write (iout,*) "ISEND ended"
8536 !      write (iout,*) "number of requests (nn)",ireq
8537       call flush(iout)
8538       if (ireq.gt.0) &
8539         call MPI_Waitall(ireq,req,status_array,ierr)
8540 !      write (iout,*)
8541 !     &  "Numbers of contacts to be received from other processors",
8542 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8543 !      call flush(iout)
8544 ! Receive contacts
8545       ireq=0
8546       do ii=1,ntask_cont_from
8547         iproc=itask_cont_from(ii)
8548         nn=ncont_recv(ii)
8549 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8550 !     &   " of CONT_TO_COMM group"
8551         call flush(iout)
8552         if (nn.gt.0) then
8553           ireq=ireq+1
8554           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8555           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8556 !          write (iout,*) "ireq,req",ireq,req(ireq)
8557         endif
8558       enddo
8559 ! Send the contacts to processors that need them
8560       do ii=1,ntask_cont_to
8561         iproc=itask_cont_to(ii)
8562         nn=ncont_sent(ii)
8563 !        write (iout,*) nn," contacts to processor",iproc,
8564 !     &   " of CONT_TO_COMM group"
8565         if (nn.gt.0) then
8566           ireq=ireq+1
8567           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8568             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8569 !          write (iout,*) "ireq,req",ireq,req(ireq)
8570 !          do i=1,nn
8571 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8572 !          enddo
8573         endif
8574       enddo
8575 !      write (iout,*) "number of requests (contacts)",ireq
8576 !      write (iout,*) "req",(req(i),i=1,4)
8577 !      call flush(iout)
8578       if (ireq.gt.0) &
8579        call MPI_Waitall(ireq,req,status_array,ierr)
8580       do iii=1,ntask_cont_from
8581         iproc=itask_cont_from(iii)
8582         nn=ncont_recv(iii)
8583         if (lprn) then
8584         write (iout,*) "Received",nn," contacts from processor",iproc,&
8585          " of CONT_FROM_COMM group"
8586         call flush(iout)
8587         do i=1,nn
8588           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8589         enddo
8590         call flush(iout)
8591         endif
8592         do i=1,nn
8593           ii=zapas_recv(1,i,iii)
8594 ! Flag the received contacts to prevent double-counting
8595           jj=-zapas_recv(2,i,iii)
8596 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8597 !          call flush(iout)
8598           nnn=num_cont_hb(ii)+1
8599           num_cont_hb(ii)=nnn
8600           jcont_hb(nnn,ii)=jj
8601           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8602           ind=3
8603           do kk=1,3
8604             ind=ind+1
8605             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8606           enddo
8607           do kk=1,2
8608             do ll=1,2
8609               ind=ind+1
8610               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8611             enddo
8612           enddo
8613           do jj=1,5
8614             do kk=1,3
8615               do ll=1,2
8616                 do mm=1,2
8617                   ind=ind+1
8618                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8619                 enddo
8620               enddo
8621             enddo
8622           enddo
8623         enddo
8624       enddo
8625       call flush(iout)
8626       if (lprn) then
8627         write (iout,'(a)') 'Contact function values after receive:'
8628         do i=nnt,nct-2
8629           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8630           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8631           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8632         enddo
8633         call flush(iout)
8634       endif
8635    30 continue
8636 #endif
8637       if (lprn) then
8638         write (iout,'(a)') 'Contact function values:'
8639         do i=nnt,nct-2
8640           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8641           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8642           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8643         enddo
8644       endif
8645       ecorr=0.0D0
8646       ecorr5=0.0d0
8647       ecorr6=0.0d0
8648
8649 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8650 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8651 ! Remove the loop below after debugging !!!
8652       do i=nnt,nct
8653         do j=1,3
8654           gradcorr(j,i)=0.0D0
8655           gradxorr(j,i)=0.0D0
8656         enddo
8657       enddo
8658 ! Calculate the dipole-dipole interaction energies
8659       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8660       do i=iatel_s,iatel_e+1
8661         num_conti=num_cont_hb(i)
8662         do jj=1,num_conti
8663           j=jcont_hb(jj,i)
8664 #ifdef MOMENT
8665           call dipole(i,j,jj)
8666 #endif
8667         enddo
8668       enddo
8669       endif
8670 ! Calculate the local-electrostatic correlation terms
8671 !                write (iout,*) "gradcorr5 in eello5 before loop"
8672 !                do iii=1,nres
8673 !                  write (iout,'(i5,3f10.5)')
8674 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8675 !                enddo
8676       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8677 !        write (iout,*) "corr loop i",i
8678         i1=i+1
8679         num_conti=num_cont_hb(i)
8680         num_conti1=num_cont_hb(i+1)
8681         do jj=1,num_conti
8682           j=jcont_hb(jj,i)
8683           jp=iabs(j)
8684           do kk=1,num_conti1
8685             j1=jcont_hb(kk,i1)
8686             jp1=iabs(j1)
8687 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8688 !     &         ' jj=',jj,' kk=',kk
8689 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8690             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8691                 .or. j.lt.0 .and. j1.gt.0) .and. &
8692                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8693 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8694 ! The system gains extra energy.
8695               n_corr=n_corr+1
8696               sqd1=dsqrt(d_cont(jj,i))
8697               sqd2=dsqrt(d_cont(kk,i1))
8698               sred_geom = sqd1*sqd2
8699               IF (sred_geom.lt.cutoff_corr) THEN
8700                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8701                   ekont,fprimcont)
8702 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8703 !d     &         ' jj=',jj,' kk=',kk
8704                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8705                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8706                 do l=1,3
8707                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8708                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8709                 enddo
8710                 n_corr1=n_corr1+1
8711 !d               write (iout,*) 'sred_geom=',sred_geom,
8712 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8713 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8714 !d               write (iout,*) "g_contij",g_contij
8715 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8716 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8717                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8718                 if (wcorr4.gt.0.0d0) &
8719                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8720                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8721                        write (iout,'(a6,4i5,0pf7.3)') &
8722                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8723 !                write (iout,*) "gradcorr5 before eello5"
8724 !                do iii=1,nres
8725 !                  write (iout,'(i5,3f10.5)')
8726 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8727 !                enddo
8728                 if (wcorr5.gt.0.0d0) &
8729                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8730 !                write (iout,*) "gradcorr5 after eello5"
8731 !                do iii=1,nres
8732 !                  write (iout,'(i5,3f10.5)')
8733 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8734 !                enddo
8735                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8736                        write (iout,'(a6,4i5,0pf7.3)') &
8737                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8738 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8739 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8740                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8741                      .or. wturn6.eq.0.0d0))then
8742 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8743                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8744                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8745                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8746 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8747 !d     &            'ecorr6=',ecorr6
8748 !d                write (iout,'(4e15.5)') sred_geom,
8749 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8750 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8751 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8752                 else if (wturn6.gt.0.0d0 &
8753                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8754 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8755                   eturn6=eturn6+eello_turn6(i,jj,kk)
8756                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8757                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8758 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8759                 endif
8760               ENDIF
8761 1111          continue
8762             endif
8763           enddo ! kk
8764         enddo ! jj
8765       enddo ! i
8766       do i=1,nres
8767         num_cont_hb(i)=num_cont_hb_old(i)
8768       enddo
8769 !                write (iout,*) "gradcorr5 in eello5"
8770 !                do iii=1,nres
8771 !                  write (iout,'(i5,3f10.5)')
8772 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8773 !                enddo
8774       return
8775       end subroutine multibody_eello
8776 !-----------------------------------------------------------------------------
8777       subroutine add_hb_contact_eello(ii,jj,itask)
8778 !      implicit real*8 (a-h,o-z)
8779 !      include "DIMENSIONS"
8780 !      include "COMMON.IOUNITS"
8781 !      include "COMMON.CONTACTS"
8782 !      integer,parameter :: maxconts=nres/4
8783       integer,parameter :: max_dim=70
8784       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8785 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8786 !      common /przechowalnia/ zapas
8787
8788       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8789       integer,dimension(4) ::itask
8790 !      write (iout,*) "itask",itask
8791       do i=1,2
8792         iproc=itask(i)
8793         if (iproc.gt.0) then
8794           do j=1,num_cont_hb(ii)
8795             jjc=jcont_hb(j,ii)
8796 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8797             if (jjc.eq.jj) then
8798               ncont_sent(iproc)=ncont_sent(iproc)+1
8799               nn=ncont_sent(iproc)
8800               zapas(1,nn,iproc)=ii
8801               zapas(2,nn,iproc)=jjc
8802               zapas(3,nn,iproc)=d_cont(j,ii)
8803               ind=3
8804               do kk=1,3
8805                 ind=ind+1
8806                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8807               enddo
8808               do kk=1,2
8809                 do ll=1,2
8810                   ind=ind+1
8811                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8812                 enddo
8813               enddo
8814               do jj=1,5
8815                 do kk=1,3
8816                   do ll=1,2
8817                     do mm=1,2
8818                       ind=ind+1
8819                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8820                     enddo
8821                   enddo
8822                 enddo
8823               enddo
8824               exit
8825             endif
8826           enddo
8827         endif
8828       enddo
8829       return
8830       end subroutine add_hb_contact_eello
8831 !-----------------------------------------------------------------------------
8832       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8833 !      implicit real*8 (a-h,o-z)
8834 !      include 'DIMENSIONS'
8835 !      include 'COMMON.IOUNITS'
8836 !      include 'COMMON.DERIV'
8837 !      include 'COMMON.INTERACT'
8838 !      include 'COMMON.CONTACTS'
8839       real(kind=8),dimension(3) :: gx,gx1
8840       logical :: lprn
8841 !el local variables
8842       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8843       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8844                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8845                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8846                    rlocshield
8847
8848       lprn=.false.
8849       eij=facont_hb(jj,i)
8850       ekl=facont_hb(kk,k)
8851       ees0pij=ees0p(jj,i)
8852       ees0pkl=ees0p(kk,k)
8853       ees0mij=ees0m(jj,i)
8854       ees0mkl=ees0m(kk,k)
8855       ekont=eij*ekl
8856       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8857 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8858 ! Following 4 lines for diagnostics.
8859 !d    ees0pkl=0.0D0
8860 !d    ees0pij=1.0D0
8861 !d    ees0mkl=0.0D0
8862 !d    ees0mij=1.0D0
8863 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8864 !     & 'Contacts ',i,j,
8865 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8866 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8867 !     & 'gradcorr_long'
8868 ! Calculate the multi-body contribution to energy.
8869 !      ecorr=ecorr+ekont*ees
8870 ! Calculate multi-body contributions to the gradient.
8871       coeffpees0pij=coeffp*ees0pij
8872       coeffmees0mij=coeffm*ees0mij
8873       coeffpees0pkl=coeffp*ees0pkl
8874       coeffmees0mkl=coeffm*ees0mkl
8875       do ll=1,3
8876 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8877         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8878         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8879         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8880         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8881         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8882         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8883 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8884         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8885         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8886         coeffmees0mij*gacontm_hb1(ll,kk,k))
8887         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8888         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8889         coeffmees0mij*gacontm_hb2(ll,kk,k))
8890         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8891            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8892            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8893         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8894         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8895         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8896            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8897            coeffmees0mij*gacontm_hb3(ll,kk,k))
8898         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8899         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8900 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8901       enddo
8902 !      write (iout,*)
8903 !grad      do m=i+1,j-1
8904 !grad        do ll=1,3
8905 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8906 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8907 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8908 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8909 !grad        enddo
8910 !grad      enddo
8911 !grad      do m=k+1,l-1
8912 !grad        do ll=1,3
8913 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8914 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8915 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8916 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8917 !grad        enddo
8918 !grad      enddo
8919 !      write (iout,*) "ehbcorr",ekont*ees
8920       ehbcorr=ekont*ees
8921       if (shield_mode.gt.0) then
8922        j=ees0plist(jj,i)
8923        l=ees0plist(kk,k)
8924 !C        print *,i,j,fac_shield(i),fac_shield(j),
8925 !C     &fac_shield(k),fac_shield(l)
8926         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8927            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8928           do ilist=1,ishield_list(i)
8929            iresshield=shield_list(ilist,i)
8930            do m=1,3
8931            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8932            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8933                    rlocshield  &
8934             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8935             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8936             +rlocshield
8937            enddo
8938           enddo
8939           do ilist=1,ishield_list(j)
8940            iresshield=shield_list(ilist,j)
8941            do m=1,3
8942            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8943            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8944                    rlocshield &
8945             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8946            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8947             +rlocshield
8948            enddo
8949           enddo
8950
8951           do ilist=1,ishield_list(k)
8952            iresshield=shield_list(ilist,k)
8953            do m=1,3
8954            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8955            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8956                    rlocshield &
8957             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8958            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8959             +rlocshield
8960            enddo
8961           enddo
8962           do ilist=1,ishield_list(l)
8963            iresshield=shield_list(ilist,l)
8964            do m=1,3
8965            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8966            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8967                    rlocshield &
8968             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8969            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8970             +rlocshield
8971            enddo
8972           enddo
8973           do m=1,3
8974             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8975                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8976             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8977                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8978             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8979                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8980             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8981                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8982
8983             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8984                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8985             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8986                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8987             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8988                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8989             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8990                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8991
8992            enddo
8993       endif
8994       endif
8995       return
8996       end function ehbcorr
8997 #ifdef MOMENT
8998 !-----------------------------------------------------------------------------
8999       subroutine dipole(i,j,jj)
9000 !      implicit real*8 (a-h,o-z)
9001 !      include 'DIMENSIONS'
9002 !      include 'COMMON.IOUNITS'
9003 !      include 'COMMON.CHAIN'
9004 !      include 'COMMON.FFIELD'
9005 !      include 'COMMON.DERIV'
9006 !      include 'COMMON.INTERACT'
9007 !      include 'COMMON.CONTACTS'
9008 !      include 'COMMON.TORSION'
9009 !      include 'COMMON.VAR'
9010 !      include 'COMMON.GEO'
9011       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
9012       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
9013       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
9014
9015       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
9016       allocate(dipderx(3,5,4,maxconts,nres))
9017 !
9018
9019       iti1 = itortyp(itype(i+1,1))
9020       if (j.lt.nres-1) then
9021         itj1 = itype2loc(itype(j+1,1))
9022       else
9023         itj1=nloctyp
9024       endif
9025       do iii=1,2
9026         dipi(iii,1)=Ub2(iii,i)
9027         dipderi(iii)=Ub2der(iii,i)
9028         dipi(iii,2)=b1(iii,iti1)
9029         dipj(iii,1)=Ub2(iii,j)
9030         dipderj(iii)=Ub2der(iii,j)
9031         dipj(iii,2)=b1(iii,itj1)
9032       enddo
9033       kkk=0
9034       do iii=1,2
9035         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9036         do jjj=1,2
9037           kkk=kkk+1
9038           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9039         enddo
9040       enddo
9041       do kkk=1,5
9042         do lll=1,3
9043           mmm=0
9044           do iii=1,2
9045             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
9046               auxvec(1))
9047             do jjj=1,2
9048               mmm=mmm+1
9049               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9050             enddo
9051           enddo
9052         enddo
9053       enddo
9054       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9055       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9056       do iii=1,2
9057         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9058       enddo
9059       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9060       do iii=1,2
9061         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9062       enddo
9063       return
9064       end subroutine dipole
9065 #endif
9066 !-----------------------------------------------------------------------------
9067       subroutine calc_eello(i,j,k,l,jj,kk)
9068 !
9069 ! This subroutine computes matrices and vectors needed to calculate
9070 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9071 !
9072       use comm_kut
9073 !      implicit real*8 (a-h,o-z)
9074 !      include 'DIMENSIONS'
9075 !      include 'COMMON.IOUNITS'
9076 !      include 'COMMON.CHAIN'
9077 !      include 'COMMON.DERIV'
9078 !      include 'COMMON.INTERACT'
9079 !      include 'COMMON.CONTACTS'
9080 !      include 'COMMON.TORSION'
9081 !      include 'COMMON.VAR'
9082 !      include 'COMMON.GEO'
9083 !      include 'COMMON.FFIELD'
9084       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9085       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9086       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9087               itj1
9088 !el      logical :: lprn
9089 !el      common /kutas/ lprn
9090 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9091 !d     & ' jj=',jj,' kk=',kk
9092 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9093 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9094 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9095       do iii=1,2
9096         do jjj=1,2
9097           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9098           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9099         enddo
9100       enddo
9101       call transpose2(aa1(1,1),aa1t(1,1))
9102       call transpose2(aa2(1,1),aa2t(1,1))
9103       do kkk=1,5
9104         do lll=1,3
9105           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9106             aa1tder(1,1,lll,kkk))
9107           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9108             aa2tder(1,1,lll,kkk))
9109         enddo
9110       enddo
9111       if (l.eq.j+1) then
9112 ! parallel orientation of the two CA-CA-CA frames.
9113         if (i.gt.1) then
9114           iti=itortyp(itype(i,1))
9115         else
9116           iti=ntortyp+1
9117         endif
9118         itk1=itortyp(itype(k+1,1))
9119         itj=itortyp(itype(j,1))
9120         if (l.lt.nres-1) then
9121           itl1=itortyp(itype(l+1,1))
9122         else
9123           itl1=ntortyp+1
9124         endif
9125 ! A1 kernel(j+1) A2T
9126 !d        do iii=1,2
9127 !d          write (iout,'(3f10.5,5x,3f10.5)')
9128 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9129 !d        enddo
9130         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9131          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9132          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9133 ! Following matrices are needed only for 6-th order cumulants
9134         IF (wcorr6.gt.0.0d0) THEN
9135         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9136          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9137          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9138         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9139          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9140          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9141          ADtEAderx(1,1,1,1,1,1))
9142         lprn=.false.
9143         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9144          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9145          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9146          ADtEA1derx(1,1,1,1,1,1))
9147         ENDIF
9148 ! End 6-th order cumulants
9149 !d        lprn=.false.
9150 !d        if (lprn) then
9151 !d        write (2,*) 'In calc_eello6'
9152 !d        do iii=1,2
9153 !d          write (2,*) 'iii=',iii
9154 !d          do kkk=1,5
9155 !d            write (2,*) 'kkk=',kkk
9156 !d            do jjj=1,2
9157 !d              write (2,'(3(2f10.5),5x)')
9158 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9159 !d            enddo
9160 !d          enddo
9161 !d        enddo
9162 !d        endif
9163         call transpose2(EUgder(1,1,k),auxmat(1,1))
9164         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9165         call transpose2(EUg(1,1,k),auxmat(1,1))
9166         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9167         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9168         do iii=1,2
9169           do kkk=1,5
9170             do lll=1,3
9171               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9172                 EAEAderx(1,1,lll,kkk,iii,1))
9173             enddo
9174           enddo
9175         enddo
9176 ! A1T kernel(i+1) A2
9177         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9178          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9179          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9180 ! Following matrices are needed only for 6-th order cumulants
9181         IF (wcorr6.gt.0.0d0) THEN
9182         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9183          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9184          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9185         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9186          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9187          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9188          ADtEAderx(1,1,1,1,1,2))
9189         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9190          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9191          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9192          ADtEA1derx(1,1,1,1,1,2))
9193         ENDIF
9194 ! End 6-th order cumulants
9195         call transpose2(EUgder(1,1,l),auxmat(1,1))
9196         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9197         call transpose2(EUg(1,1,l),auxmat(1,1))
9198         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9199         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9200         do iii=1,2
9201           do kkk=1,5
9202             do lll=1,3
9203               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9204                 EAEAderx(1,1,lll,kkk,iii,2))
9205             enddo
9206           enddo
9207         enddo
9208 ! AEAb1 and AEAb2
9209 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9210 ! They are needed only when the fifth- or the sixth-order cumulants are
9211 ! indluded.
9212         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9213         call transpose2(AEA(1,1,1),auxmat(1,1))
9214         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9215         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9216         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9217         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9218         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9219         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9220         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9221         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9222         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9223         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9224         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9225         call transpose2(AEA(1,1,2),auxmat(1,1))
9226         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9227         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9228         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9229         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9230         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9231         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9232         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9233         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9234         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9235         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9236         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9237 ! Calculate the Cartesian derivatives of the vectors.
9238         do iii=1,2
9239           do kkk=1,5
9240             do lll=1,3
9241               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9242               call matvec2(auxmat(1,1),b1(1,iti),&
9243                 AEAb1derx(1,lll,kkk,iii,1,1))
9244               call matvec2(auxmat(1,1),Ub2(1,i),&
9245                 AEAb2derx(1,lll,kkk,iii,1,1))
9246               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9247                 AEAb1derx(1,lll,kkk,iii,2,1))
9248               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9249                 AEAb2derx(1,lll,kkk,iii,2,1))
9250               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9251               call matvec2(auxmat(1,1),b1(1,itj),&
9252                 AEAb1derx(1,lll,kkk,iii,1,2))
9253               call matvec2(auxmat(1,1),Ub2(1,j),&
9254                 AEAb2derx(1,lll,kkk,iii,1,2))
9255               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9256                 AEAb1derx(1,lll,kkk,iii,2,2))
9257               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9258                 AEAb2derx(1,lll,kkk,iii,2,2))
9259             enddo
9260           enddo
9261         enddo
9262         ENDIF
9263 ! End vectors
9264       else
9265 ! Antiparallel orientation of the two CA-CA-CA frames.
9266         if (i.gt.1) then
9267           iti=itortyp(itype(i,1))
9268         else
9269           iti=ntortyp+1
9270         endif
9271         itk1=itortyp(itype(k+1,1))
9272         itl=itortyp(itype(l,1))
9273         itj=itortyp(itype(j,1))
9274         if (j.lt.nres-1) then
9275           itj1=itortyp(itype(j+1,1))
9276         else
9277           itj1=ntortyp+1
9278         endif
9279 ! A2 kernel(j-1)T A1T
9280         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9281          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9282          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9283 ! Following matrices are needed only for 6-th order cumulants
9284         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9285            j.eq.i+4 .and. l.eq.i+3)) THEN
9286         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9287          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9288          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9289         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9290          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9291          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9292          ADtEAderx(1,1,1,1,1,1))
9293         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9294          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9295          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9296          ADtEA1derx(1,1,1,1,1,1))
9297         ENDIF
9298 ! End 6-th order cumulants
9299         call transpose2(EUgder(1,1,k),auxmat(1,1))
9300         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9301         call transpose2(EUg(1,1,k),auxmat(1,1))
9302         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9303         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9304         do iii=1,2
9305           do kkk=1,5
9306             do lll=1,3
9307               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9308                 EAEAderx(1,1,lll,kkk,iii,1))
9309             enddo
9310           enddo
9311         enddo
9312 ! A2T kernel(i+1)T A1
9313         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9314          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9315          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9316 ! Following matrices are needed only for 6-th order cumulants
9317         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9318            j.eq.i+4 .and. l.eq.i+3)) THEN
9319         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9320          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9321          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9322         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9323          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9324          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9325          ADtEAderx(1,1,1,1,1,2))
9326         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9327          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9328          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9329          ADtEA1derx(1,1,1,1,1,2))
9330         ENDIF
9331 ! End 6-th order cumulants
9332         call transpose2(EUgder(1,1,j),auxmat(1,1))
9333         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9334         call transpose2(EUg(1,1,j),auxmat(1,1))
9335         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9336         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9337         do iii=1,2
9338           do kkk=1,5
9339             do lll=1,3
9340               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9341                 EAEAderx(1,1,lll,kkk,iii,2))
9342             enddo
9343           enddo
9344         enddo
9345 ! AEAb1 and AEAb2
9346 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9347 ! They are needed only when the fifth- or the sixth-order cumulants are
9348 ! indluded.
9349         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9350           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9351         call transpose2(AEA(1,1,1),auxmat(1,1))
9352         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9353         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9354         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9355         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9356         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9357         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9358         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9359         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9360         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9361         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9362         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9363         call transpose2(AEA(1,1,2),auxmat(1,1))
9364         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9365         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9366         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9367         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9368         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9369         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9370         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9371         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9372         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9373         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9374         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9375 ! Calculate the Cartesian derivatives of the vectors.
9376         do iii=1,2
9377           do kkk=1,5
9378             do lll=1,3
9379               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9380               call matvec2(auxmat(1,1),b1(1,iti),&
9381                 AEAb1derx(1,lll,kkk,iii,1,1))
9382               call matvec2(auxmat(1,1),Ub2(1,i),&
9383                 AEAb2derx(1,lll,kkk,iii,1,1))
9384               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9385                 AEAb1derx(1,lll,kkk,iii,2,1))
9386               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9387                 AEAb2derx(1,lll,kkk,iii,2,1))
9388               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9389               call matvec2(auxmat(1,1),b1(1,itl),&
9390                 AEAb1derx(1,lll,kkk,iii,1,2))
9391               call matvec2(auxmat(1,1),Ub2(1,l),&
9392                 AEAb2derx(1,lll,kkk,iii,1,2))
9393               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9394                 AEAb1derx(1,lll,kkk,iii,2,2))
9395               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9396                 AEAb2derx(1,lll,kkk,iii,2,2))
9397             enddo
9398           enddo
9399         enddo
9400         ENDIF
9401 ! End vectors
9402       endif
9403       return
9404       end subroutine calc_eello
9405 !-----------------------------------------------------------------------------
9406       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9407       use comm_kut
9408       implicit none
9409       integer :: nderg
9410       logical :: transp
9411       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9412       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9413       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9414       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9415       integer :: iii,kkk,lll
9416       integer :: jjj,mmm
9417 !el      logical :: lprn
9418 !el      common /kutas/ lprn
9419       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9420       do iii=1,nderg
9421         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9422           AKAderg(1,1,iii))
9423       enddo
9424 !d      if (lprn) write (2,*) 'In kernel'
9425       do kkk=1,5
9426 !d        if (lprn) write (2,*) 'kkk=',kkk
9427         do lll=1,3
9428           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9429             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9430 !d          if (lprn) then
9431 !d            write (2,*) 'lll=',lll
9432 !d            write (2,*) 'iii=1'
9433 !d            do jjj=1,2
9434 !d              write (2,'(3(2f10.5),5x)')
9435 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9436 !d            enddo
9437 !d          endif
9438           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9439             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9440 !d          if (lprn) then
9441 !d            write (2,*) 'lll=',lll
9442 !d            write (2,*) 'iii=2'
9443 !d            do jjj=1,2
9444 !d              write (2,'(3(2f10.5),5x)')
9445 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9446 !d            enddo
9447 !d          endif
9448         enddo
9449       enddo
9450       return
9451       end subroutine kernel
9452 !-----------------------------------------------------------------------------
9453       real(kind=8) function eello4(i,j,k,l,jj,kk)
9454 !      implicit real*8 (a-h,o-z)
9455 !      include 'DIMENSIONS'
9456 !      include 'COMMON.IOUNITS'
9457 !      include 'COMMON.CHAIN'
9458 !      include 'COMMON.DERIV'
9459 !      include 'COMMON.INTERACT'
9460 !      include 'COMMON.CONTACTS'
9461 !      include 'COMMON.TORSION'
9462 !      include 'COMMON.VAR'
9463 !      include 'COMMON.GEO'
9464       real(kind=8),dimension(2,2) :: pizda
9465       real(kind=8),dimension(3) :: ggg1,ggg2
9466       real(kind=8) ::  eel4,glongij,glongkl
9467       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9468 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9469 !d        eello4=0.0d0
9470 !d        return
9471 !d      endif
9472 !d      print *,'eello4:',i,j,k,l,jj,kk
9473 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9474 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9475 !old      eij=facont_hb(jj,i)
9476 !old      ekl=facont_hb(kk,k)
9477 !old      ekont=eij*ekl
9478       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9479 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9480       gcorr_loc(k-1)=gcorr_loc(k-1) &
9481          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9482       if (l.eq.j+1) then
9483         gcorr_loc(l-1)=gcorr_loc(l-1) &
9484            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9485       else
9486         gcorr_loc(j-1)=gcorr_loc(j-1) &
9487            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9488       endif
9489       do iii=1,2
9490         do kkk=1,5
9491           do lll=1,3
9492             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9493                               -EAEAderx(2,2,lll,kkk,iii,1)
9494 !d            derx(lll,kkk,iii)=0.0d0
9495           enddo
9496         enddo
9497       enddo
9498 !d      gcorr_loc(l-1)=0.0d0
9499 !d      gcorr_loc(j-1)=0.0d0
9500 !d      gcorr_loc(k-1)=0.0d0
9501 !d      eel4=1.0d0
9502 !d      write (iout,*)'Contacts have occurred for peptide groups',
9503 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9504 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9505       if (j.lt.nres-1) then
9506         j1=j+1
9507         j2=j-1
9508       else
9509         j1=j-1
9510         j2=j-2
9511       endif
9512       if (l.lt.nres-1) then
9513         l1=l+1
9514         l2=l-1
9515       else
9516         l1=l-1
9517         l2=l-2
9518       endif
9519       do ll=1,3
9520 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9521 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9522         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9523         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9524 !grad        ghalf=0.5d0*ggg1(ll)
9525         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9526         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9527         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9528         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9529         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9530         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9531 !grad        ghalf=0.5d0*ggg2(ll)
9532         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9533         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9534         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9535         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9536         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9537         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9538       enddo
9539 !grad      do m=i+1,j-1
9540 !grad        do ll=1,3
9541 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9542 !grad        enddo
9543 !grad      enddo
9544 !grad      do m=k+1,l-1
9545 !grad        do ll=1,3
9546 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9547 !grad        enddo
9548 !grad      enddo
9549 !grad      do m=i+2,j2
9550 !grad        do ll=1,3
9551 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9552 !grad        enddo
9553 !grad      enddo
9554 !grad      do m=k+2,l2
9555 !grad        do ll=1,3
9556 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9557 !grad        enddo
9558 !grad      enddo
9559 !d      do iii=1,nres-3
9560 !d        write (2,*) iii,gcorr_loc(iii)
9561 !d      enddo
9562       eello4=ekont*eel4
9563 !d      write (2,*) 'ekont',ekont
9564 !d      write (iout,*) 'eello4',ekont*eel4
9565       return
9566       end function eello4
9567 !-----------------------------------------------------------------------------
9568       real(kind=8) function eello5(i,j,k,l,jj,kk)
9569 !      implicit real*8 (a-h,o-z)
9570 !      include 'DIMENSIONS'
9571 !      include 'COMMON.IOUNITS'
9572 !      include 'COMMON.CHAIN'
9573 !      include 'COMMON.DERIV'
9574 !      include 'COMMON.INTERACT'
9575 !      include 'COMMON.CONTACTS'
9576 !      include 'COMMON.TORSION'
9577 !      include 'COMMON.VAR'
9578 !      include 'COMMON.GEO'
9579       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9580       real(kind=8),dimension(2) :: vv
9581       real(kind=8),dimension(3) :: ggg1,ggg2
9582       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9583       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9584       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9585 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9586 !                                                                              C
9587 !                            Parallel chains                                   C
9588 !                                                                              C
9589 !          o             o                   o             o                   C
9590 !         /l\           / \             \   / \           / \   /              C
9591 !        /   \         /   \             \ /   \         /   \ /               C
9592 !       j| o |l1       | o |                o| o |         | o |o                C
9593 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9594 !      \i/   \         /   \ /             /   \         /   \                 C
9595 !       o    k1             o                                                  C
9596 !         (I)          (II)                (III)          (IV)                 C
9597 !                                                                              C
9598 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9599 !                                                                              C
9600 !                            Antiparallel chains                               C
9601 !                                                                              C
9602 !          o             o                   o             o                   C
9603 !         /j\           / \             \   / \           / \   /              C
9604 !        /   \         /   \             \ /   \         /   \ /               C
9605 !      j1| o |l        | o |                o| o |         | o |o                C
9606 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9607 !      \i/   \         /   \ /             /   \         /   \                 C
9608 !       o     k1            o                                                  C
9609 !         (I)          (II)                (III)          (IV)                 C
9610 !                                                                              C
9611 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9612 !                                                                              C
9613 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9614 !                                                                              C
9615 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9616 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9617 !d        eello5=0.0d0
9618 !d        return
9619 !d      endif
9620 !d      write (iout,*)
9621 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9622 !d     &   ' and',k,l
9623       itk=itortyp(itype(k,1))
9624       itl=itortyp(itype(l,1))
9625       itj=itortyp(itype(j,1))
9626       eello5_1=0.0d0
9627       eello5_2=0.0d0
9628       eello5_3=0.0d0
9629       eello5_4=0.0d0
9630 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9631 !d     &   eel5_3_num,eel5_4_num)
9632       do iii=1,2
9633         do kkk=1,5
9634           do lll=1,3
9635             derx(lll,kkk,iii)=0.0d0
9636           enddo
9637         enddo
9638       enddo
9639 !d      eij=facont_hb(jj,i)
9640 !d      ekl=facont_hb(kk,k)
9641 !d      ekont=eij*ekl
9642 !d      write (iout,*)'Contacts have occurred for peptide groups',
9643 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9644 !d      goto 1111
9645 ! Contribution from the graph I.
9646 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9647 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9648       call transpose2(EUg(1,1,k),auxmat(1,1))
9649       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9650       vv(1)=pizda(1,1)-pizda(2,2)
9651       vv(2)=pizda(1,2)+pizda(2,1)
9652       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9653        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9654 ! Explicit gradient in virtual-dihedral angles.
9655       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9656        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9657        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9658       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9659       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9660       vv(1)=pizda(1,1)-pizda(2,2)
9661       vv(2)=pizda(1,2)+pizda(2,1)
9662       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9663        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9664        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9665       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9666       vv(1)=pizda(1,1)-pizda(2,2)
9667       vv(2)=pizda(1,2)+pizda(2,1)
9668       if (l.eq.j+1) then
9669         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9670          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9671          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9672       else
9673         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9674          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9675          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9676       endif
9677 ! Cartesian gradient
9678       do iii=1,2
9679         do kkk=1,5
9680           do lll=1,3
9681             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9682               pizda(1,1))
9683             vv(1)=pizda(1,1)-pizda(2,2)
9684             vv(2)=pizda(1,2)+pizda(2,1)
9685             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9686              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9687              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9688           enddo
9689         enddo
9690       enddo
9691 !      goto 1112
9692 !1111  continue
9693 ! Contribution from graph II
9694       call transpose2(EE(1,1,itk),auxmat(1,1))
9695       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9696       vv(1)=pizda(1,1)+pizda(2,2)
9697       vv(2)=pizda(2,1)-pizda(1,2)
9698       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9699        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9700 ! Explicit gradient in virtual-dihedral angles.
9701       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9702        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9703       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9704       vv(1)=pizda(1,1)+pizda(2,2)
9705       vv(2)=pizda(2,1)-pizda(1,2)
9706       if (l.eq.j+1) then
9707         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9708          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9709          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9710       else
9711         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9712          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9713          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9714       endif
9715 ! Cartesian gradient
9716       do iii=1,2
9717         do kkk=1,5
9718           do lll=1,3
9719             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9720               pizda(1,1))
9721             vv(1)=pizda(1,1)+pizda(2,2)
9722             vv(2)=pizda(2,1)-pizda(1,2)
9723             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9724              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9725              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9726           enddo
9727         enddo
9728       enddo
9729 !d      goto 1112
9730 !d1111  continue
9731       if (l.eq.j+1) then
9732 !d        goto 1110
9733 ! Parallel orientation
9734 ! Contribution from graph III
9735         call transpose2(EUg(1,1,l),auxmat(1,1))
9736         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9737         vv(1)=pizda(1,1)-pizda(2,2)
9738         vv(2)=pizda(1,2)+pizda(2,1)
9739         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9740          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9741 ! Explicit gradient in virtual-dihedral angles.
9742         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9743          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9744          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9745         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9746         vv(1)=pizda(1,1)-pizda(2,2)
9747         vv(2)=pizda(1,2)+pizda(2,1)
9748         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9749          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9750          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9751         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9752         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9753         vv(1)=pizda(1,1)-pizda(2,2)
9754         vv(2)=pizda(1,2)+pizda(2,1)
9755         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9756          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9757          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9758 ! Cartesian gradient
9759         do iii=1,2
9760           do kkk=1,5
9761             do lll=1,3
9762               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9763                 pizda(1,1))
9764               vv(1)=pizda(1,1)-pizda(2,2)
9765               vv(2)=pizda(1,2)+pizda(2,1)
9766               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9767                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9768                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9769             enddo
9770           enddo
9771         enddo
9772 !d        goto 1112
9773 ! Contribution from graph IV
9774 !d1110    continue
9775         call transpose2(EE(1,1,itl),auxmat(1,1))
9776         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9777         vv(1)=pizda(1,1)+pizda(2,2)
9778         vv(2)=pizda(2,1)-pizda(1,2)
9779         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9780          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9781 ! Explicit gradient in virtual-dihedral angles.
9782         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9783          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9784         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9785         vv(1)=pizda(1,1)+pizda(2,2)
9786         vv(2)=pizda(2,1)-pizda(1,2)
9787         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9788          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9789          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9790 ! Cartesian gradient
9791         do iii=1,2
9792           do kkk=1,5
9793             do lll=1,3
9794               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9795                 pizda(1,1))
9796               vv(1)=pizda(1,1)+pizda(2,2)
9797               vv(2)=pizda(2,1)-pizda(1,2)
9798               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9799                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9800                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9801             enddo
9802           enddo
9803         enddo
9804       else
9805 ! Antiparallel orientation
9806 ! Contribution from graph III
9807 !        goto 1110
9808         call transpose2(EUg(1,1,j),auxmat(1,1))
9809         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9810         vv(1)=pizda(1,1)-pizda(2,2)
9811         vv(2)=pizda(1,2)+pizda(2,1)
9812         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9813          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9814 ! Explicit gradient in virtual-dihedral angles.
9815         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9816          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9817          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9818         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9819         vv(1)=pizda(1,1)-pizda(2,2)
9820         vv(2)=pizda(1,2)+pizda(2,1)
9821         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9822          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9823          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9824         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9825         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9826         vv(1)=pizda(1,1)-pizda(2,2)
9827         vv(2)=pizda(1,2)+pizda(2,1)
9828         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9829          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9830          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9831 ! Cartesian gradient
9832         do iii=1,2
9833           do kkk=1,5
9834             do lll=1,3
9835               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9836                 pizda(1,1))
9837               vv(1)=pizda(1,1)-pizda(2,2)
9838               vv(2)=pizda(1,2)+pizda(2,1)
9839               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9840                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9841                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9842             enddo
9843           enddo
9844         enddo
9845 !d        goto 1112
9846 ! Contribution from graph IV
9847 1110    continue
9848         call transpose2(EE(1,1,itj),auxmat(1,1))
9849         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9850         vv(1)=pizda(1,1)+pizda(2,2)
9851         vv(2)=pizda(2,1)-pizda(1,2)
9852         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9853          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9854 ! Explicit gradient in virtual-dihedral angles.
9855         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9856          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9857         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9858         vv(1)=pizda(1,1)+pizda(2,2)
9859         vv(2)=pizda(2,1)-pizda(1,2)
9860         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9861          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9862          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9863 ! Cartesian gradient
9864         do iii=1,2
9865           do kkk=1,5
9866             do lll=1,3
9867               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9868                 pizda(1,1))
9869               vv(1)=pizda(1,1)+pizda(2,2)
9870               vv(2)=pizda(2,1)-pizda(1,2)
9871               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9872                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9873                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9874             enddo
9875           enddo
9876         enddo
9877       endif
9878 1112  continue
9879       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9880 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9881 !d        write (2,*) 'ijkl',i,j,k,l
9882 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9883 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9884 !d      endif
9885 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9886 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9887 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9888 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9889       if (j.lt.nres-1) then
9890         j1=j+1
9891         j2=j-1
9892       else
9893         j1=j-1
9894         j2=j-2
9895       endif
9896       if (l.lt.nres-1) then
9897         l1=l+1
9898         l2=l-1
9899       else
9900         l1=l-1
9901         l2=l-2
9902       endif
9903 !d      eij=1.0d0
9904 !d      ekl=1.0d0
9905 !d      ekont=1.0d0
9906 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9907 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9908 !        summed up outside the subrouine as for the other subroutines
9909 !        handling long-range interactions. The old code is commented out
9910 !        with "cgrad" to keep track of changes.
9911       do ll=1,3
9912 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9913 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9914         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9915         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9916 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9917 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9918 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9919 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9920 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9921 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9922 !     &   gradcorr5ij,
9923 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9924 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9925 !grad        ghalf=0.5d0*ggg1(ll)
9926 !d        ghalf=0.0d0
9927         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9928         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9929         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9930         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9931         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9932         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9933 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9934 !grad        ghalf=0.5d0*ggg2(ll)
9935         ghalf=0.0d0
9936         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9937         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9938         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9939         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9940         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9941         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9942       enddo
9943 !d      goto 1112
9944 !grad      do m=i+1,j-1
9945 !grad        do ll=1,3
9946 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9947 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9948 !grad        enddo
9949 !grad      enddo
9950 !grad      do m=k+1,l-1
9951 !grad        do ll=1,3
9952 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9953 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9954 !grad        enddo
9955 !grad      enddo
9956 !1112  continue
9957 !grad      do m=i+2,j2
9958 !grad        do ll=1,3
9959 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9960 !grad        enddo
9961 !grad      enddo
9962 !grad      do m=k+2,l2
9963 !grad        do ll=1,3
9964 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9965 !grad        enddo
9966 !grad      enddo
9967 !d      do iii=1,nres-3
9968 !d        write (2,*) iii,g_corr5_loc(iii)
9969 !d      enddo
9970       eello5=ekont*eel5
9971 !d      write (2,*) 'ekont',ekont
9972 !d      write (iout,*) 'eello5',ekont*eel5
9973       return
9974       end function eello5
9975 !-----------------------------------------------------------------------------
9976       real(kind=8) function eello6(i,j,k,l,jj,kk)
9977 !      implicit real*8 (a-h,o-z)
9978 !      include 'DIMENSIONS'
9979 !      include 'COMMON.IOUNITS'
9980 !      include 'COMMON.CHAIN'
9981 !      include 'COMMON.DERIV'
9982 !      include 'COMMON.INTERACT'
9983 !      include 'COMMON.CONTACTS'
9984 !      include 'COMMON.TORSION'
9985 !      include 'COMMON.VAR'
9986 !      include 'COMMON.GEO'
9987 !      include 'COMMON.FFIELD'
9988       real(kind=8),dimension(3) :: ggg1,ggg2
9989       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9990                    eello6_6,eel6
9991       real(kind=8) :: gradcorr6ij,gradcorr6kl
9992       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9993 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9994 !d        eello6=0.0d0
9995 !d        return
9996 !d      endif
9997 !d      write (iout,*)
9998 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9999 !d     &   ' and',k,l
10000       eello6_1=0.0d0
10001       eello6_2=0.0d0
10002       eello6_3=0.0d0
10003       eello6_4=0.0d0
10004       eello6_5=0.0d0
10005       eello6_6=0.0d0
10006 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10007 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10008       do iii=1,2
10009         do kkk=1,5
10010           do lll=1,3
10011             derx(lll,kkk,iii)=0.0d0
10012           enddo
10013         enddo
10014       enddo
10015 !d      eij=facont_hb(jj,i)
10016 !d      ekl=facont_hb(kk,k)
10017 !d      ekont=eij*ekl
10018 !d      eij=1.0d0
10019 !d      ekl=1.0d0
10020 !d      ekont=1.0d0
10021       if (l.eq.j+1) then
10022         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10023         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10024         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10025         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10026         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10027         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10028       else
10029         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10030         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10031         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10032         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10033         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10034           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10035         else
10036           eello6_5=0.0d0
10037         endif
10038         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10039       endif
10040 ! If turn contributions are considered, they will be handled separately.
10041       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10042 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10043 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10044 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10045 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10046 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10047 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10048 !d      goto 1112
10049       if (j.lt.nres-1) then
10050         j1=j+1
10051         j2=j-1
10052       else
10053         j1=j-1
10054         j2=j-2
10055       endif
10056       if (l.lt.nres-1) then
10057         l1=l+1
10058         l2=l-1
10059       else
10060         l1=l-1
10061         l2=l-2
10062       endif
10063       do ll=1,3
10064 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10065 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10066 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10067 !grad        ghalf=0.5d0*ggg1(ll)
10068 !d        ghalf=0.0d0
10069         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10070         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10071         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10072         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10073         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10074         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10075         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10076         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10077 !grad        ghalf=0.5d0*ggg2(ll)
10078 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10079 !d        ghalf=0.0d0
10080         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10081         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10082         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10083         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10084         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10085         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10086       enddo
10087 !d      goto 1112
10088 !grad      do m=i+1,j-1
10089 !grad        do ll=1,3
10090 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10091 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10092 !grad        enddo
10093 !grad      enddo
10094 !grad      do m=k+1,l-1
10095 !grad        do ll=1,3
10096 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10097 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10098 !grad        enddo
10099 !grad      enddo
10100 !grad1112  continue
10101 !grad      do m=i+2,j2
10102 !grad        do ll=1,3
10103 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10104 !grad        enddo
10105 !grad      enddo
10106 !grad      do m=k+2,l2
10107 !grad        do ll=1,3
10108 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10109 !grad        enddo
10110 !grad      enddo
10111 !d      do iii=1,nres-3
10112 !d        write (2,*) iii,g_corr6_loc(iii)
10113 !d      enddo
10114       eello6=ekont*eel6
10115 !d      write (2,*) 'ekont',ekont
10116 !d      write (iout,*) 'eello6',ekont*eel6
10117       return
10118       end function eello6
10119 !-----------------------------------------------------------------------------
10120       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10121       use comm_kut
10122 !      implicit real*8 (a-h,o-z)
10123 !      include 'DIMENSIONS'
10124 !      include 'COMMON.IOUNITS'
10125 !      include 'COMMON.CHAIN'
10126 !      include 'COMMON.DERIV'
10127 !      include 'COMMON.INTERACT'
10128 !      include 'COMMON.CONTACTS'
10129 !      include 'COMMON.TORSION'
10130 !      include 'COMMON.VAR'
10131 !      include 'COMMON.GEO'
10132       real(kind=8),dimension(2) :: vv,vv1
10133       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10134       logical :: swap
10135 !el      logical :: lprn
10136 !el      common /kutas/ lprn
10137       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10138       real(kind=8) :: s1,s2,s3,s4,s5
10139 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10140 !                                                                              C
10141 !      Parallel       Antiparallel                                             C
10142 !                                                                              C
10143 !          o             o                                                     C
10144 !         /l\           /j\                                                    C
10145 !        /   \         /   \                                                   C
10146 !       /| o |         | o |\                                                  C
10147 !     \ j|/k\|  /   \  |/k\|l /                                                C
10148 !      \ /   \ /     \ /   \ /                                                 C
10149 !       o     o       o     o                                                  C
10150 !       i             i                                                        C
10151 !                                                                              C
10152 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10153       itk=itortyp(itype(k,1))
10154       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10155       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10156       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10157       call transpose2(EUgC(1,1,k),auxmat(1,1))
10158       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10159       vv1(1)=pizda1(1,1)-pizda1(2,2)
10160       vv1(2)=pizda1(1,2)+pizda1(2,1)
10161       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10162       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10163       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10164       s5=scalar2(vv(1),Dtobr2(1,i))
10165 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10166       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10167       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10168        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10169        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10170        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10171        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10172        +scalar2(vv(1),Dtobr2der(1,i)))
10173       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10174       vv1(1)=pizda1(1,1)-pizda1(2,2)
10175       vv1(2)=pizda1(1,2)+pizda1(2,1)
10176       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10177       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10178       if (l.eq.j+1) then
10179         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10180        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10181        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10182        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10183        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10184       else
10185         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10186        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10187        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10188        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10189        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10190       endif
10191       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10192       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10193       vv1(1)=pizda1(1,1)-pizda1(2,2)
10194       vv1(2)=pizda1(1,2)+pizda1(2,1)
10195       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10196        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10197        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10198        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10199       do iii=1,2
10200         if (swap) then
10201           ind=3-iii
10202         else
10203           ind=iii
10204         endif
10205         do kkk=1,5
10206           do lll=1,3
10207             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10208             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10209             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10210             call transpose2(EUgC(1,1,k),auxmat(1,1))
10211             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10212               pizda1(1,1))
10213             vv1(1)=pizda1(1,1)-pizda1(2,2)
10214             vv1(2)=pizda1(1,2)+pizda1(2,1)
10215             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10216             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10217              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10218             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10219              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10220             s5=scalar2(vv(1),Dtobr2(1,i))
10221             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10222           enddo
10223         enddo
10224       enddo
10225       return
10226       end function eello6_graph1
10227 !-----------------------------------------------------------------------------
10228       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10229       use comm_kut
10230 !      implicit real*8 (a-h,o-z)
10231 !      include 'DIMENSIONS'
10232 !      include 'COMMON.IOUNITS'
10233 !      include 'COMMON.CHAIN'
10234 !      include 'COMMON.DERIV'
10235 !      include 'COMMON.INTERACT'
10236 !      include 'COMMON.CONTACTS'
10237 !      include 'COMMON.TORSION'
10238 !      include 'COMMON.VAR'
10239 !      include 'COMMON.GEO'
10240       logical :: swap
10241       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10242       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10243 !el      logical :: lprn
10244 !el      common /kutas/ lprn
10245       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10246       real(kind=8) :: s2,s3,s4
10247 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10248 !                                                                              C
10249 !      Parallel       Antiparallel                                             C
10250 !                                                                              C
10251 !          o             o                                                     C
10252 !     \   /l\           /j\   /                                                C
10253 !      \ /   \         /   \ /                                                 C
10254 !       o| o |         | o |o                                                  C
10255 !     \ j|/k\|      \  |/k\|l                                                  C
10256 !      \ /   \       \ /   \                                                   C
10257 !       o             o                                                        C
10258 !       i             i                                                        C
10259 !                                                                              C
10260 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10261 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10262 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10263 !           but not in a cluster cumulant
10264 #ifdef MOMENT
10265       s1=dip(1,jj,i)*dip(1,kk,k)
10266 #endif
10267       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10268       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10269       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10270       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10271       call transpose2(EUg(1,1,k),auxmat(1,1))
10272       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10273       vv(1)=pizda(1,1)-pizda(2,2)
10274       vv(2)=pizda(1,2)+pizda(2,1)
10275       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10276 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10277 #ifdef MOMENT
10278       eello6_graph2=-(s1+s2+s3+s4)
10279 #else
10280       eello6_graph2=-(s2+s3+s4)
10281 #endif
10282 !      eello6_graph2=-s3
10283 ! Derivatives in gamma(i-1)
10284       if (i.gt.1) then
10285 #ifdef MOMENT
10286         s1=dipderg(1,jj,i)*dip(1,kk,k)
10287 #endif
10288         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10289         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10290         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10291         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10292 #ifdef MOMENT
10293         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10294 #else
10295         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10296 #endif
10297 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10298       endif
10299 ! Derivatives in gamma(k-1)
10300 #ifdef MOMENT
10301       s1=dip(1,jj,i)*dipderg(1,kk,k)
10302 #endif
10303       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10304       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10305       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10306       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10307       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10308       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10309       vv(1)=pizda(1,1)-pizda(2,2)
10310       vv(2)=pizda(1,2)+pizda(2,1)
10311       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10312 #ifdef MOMENT
10313       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10314 #else
10315       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10316 #endif
10317 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10318 ! Derivatives in gamma(j-1) or gamma(l-1)
10319       if (j.gt.1) then
10320 #ifdef MOMENT
10321         s1=dipderg(3,jj,i)*dip(1,kk,k)
10322 #endif
10323         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10324         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10325         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10326         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10327         vv(1)=pizda(1,1)-pizda(2,2)
10328         vv(2)=pizda(1,2)+pizda(2,1)
10329         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10330 #ifdef MOMENT
10331         if (swap) then
10332           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10333         else
10334           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10335         endif
10336 #endif
10337         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10338 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10339       endif
10340 ! Derivatives in gamma(l-1) or gamma(j-1)
10341       if (l.gt.1) then
10342 #ifdef MOMENT
10343         s1=dip(1,jj,i)*dipderg(3,kk,k)
10344 #endif
10345         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10346         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10347         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10348         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10349         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10350         vv(1)=pizda(1,1)-pizda(2,2)
10351         vv(2)=pizda(1,2)+pizda(2,1)
10352         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10353 #ifdef MOMENT
10354         if (swap) then
10355           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10356         else
10357           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10358         endif
10359 #endif
10360         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10361 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10362       endif
10363 ! Cartesian derivatives.
10364       if (lprn) then
10365         write (2,*) 'In eello6_graph2'
10366         do iii=1,2
10367           write (2,*) 'iii=',iii
10368           do kkk=1,5
10369             write (2,*) 'kkk=',kkk
10370             do jjj=1,2
10371               write (2,'(3(2f10.5),5x)') &
10372               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10373             enddo
10374           enddo
10375         enddo
10376       endif
10377       do iii=1,2
10378         do kkk=1,5
10379           do lll=1,3
10380 #ifdef MOMENT
10381             if (iii.eq.1) then
10382               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10383             else
10384               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10385             endif
10386 #endif
10387             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10388               auxvec(1))
10389             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10390             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10391               auxvec(1))
10392             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10393             call transpose2(EUg(1,1,k),auxmat(1,1))
10394             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10395               pizda(1,1))
10396             vv(1)=pizda(1,1)-pizda(2,2)
10397             vv(2)=pizda(1,2)+pizda(2,1)
10398             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10399 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10400 #ifdef MOMENT
10401             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10402 #else
10403             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10404 #endif
10405             if (swap) then
10406               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10407             else
10408               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10409             endif
10410           enddo
10411         enddo
10412       enddo
10413       return
10414       end function eello6_graph2
10415 !-----------------------------------------------------------------------------
10416       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10417 !      implicit real*8 (a-h,o-z)
10418 !      include 'DIMENSIONS'
10419 !      include 'COMMON.IOUNITS'
10420 !      include 'COMMON.CHAIN'
10421 !      include 'COMMON.DERIV'
10422 !      include 'COMMON.INTERACT'
10423 !      include 'COMMON.CONTACTS'
10424 !      include 'COMMON.TORSION'
10425 !      include 'COMMON.VAR'
10426 !      include 'COMMON.GEO'
10427       real(kind=8),dimension(2) :: vv,auxvec
10428       real(kind=8),dimension(2,2) :: pizda,auxmat
10429       logical :: swap
10430       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10431       real(kind=8) :: s1,s2,s3,s4
10432 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10433 !                                                                              C
10434 !      Parallel       Antiparallel                                             C
10435 !                                                                              C
10436 !          o             o                                                     C
10437 !         /l\   /   \   /j\                                                    C
10438 !        /   \ /     \ /   \                                                   C
10439 !       /| o |o       o| o |\                                                  C
10440 !       j|/k\|  /      |/k\|l /                                                C
10441 !        /   \ /       /   \ /                                                 C
10442 !       /     o       /     o                                                  C
10443 !       i             i                                                        C
10444 !                                                                              C
10445 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10446 !
10447 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10448 !           energy moment and not to the cluster cumulant.
10449       iti=itortyp(itype(i,1))
10450       if (j.lt.nres-1) then
10451         itj1=itortyp(itype(j+1,1))
10452       else
10453         itj1=ntortyp+1
10454       endif
10455       itk=itortyp(itype(k,1))
10456       itk1=itortyp(itype(k+1,1))
10457       if (l.lt.nres-1) then
10458         itl1=itortyp(itype(l+1,1))
10459       else
10460         itl1=ntortyp+1
10461       endif
10462 #ifdef MOMENT
10463       s1=dip(4,jj,i)*dip(4,kk,k)
10464 #endif
10465       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10466       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10467       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10468       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10469       call transpose2(EE(1,1,itk),auxmat(1,1))
10470       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10471       vv(1)=pizda(1,1)+pizda(2,2)
10472       vv(2)=pizda(2,1)-pizda(1,2)
10473       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10474 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10475 !d     & "sum",-(s2+s3+s4)
10476 #ifdef MOMENT
10477       eello6_graph3=-(s1+s2+s3+s4)
10478 #else
10479       eello6_graph3=-(s2+s3+s4)
10480 #endif
10481 !      eello6_graph3=-s4
10482 ! Derivatives in gamma(k-1)
10483       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10484       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10485       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10486       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10487 ! Derivatives in gamma(l-1)
10488       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10489       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10490       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10491       vv(1)=pizda(1,1)+pizda(2,2)
10492       vv(2)=pizda(2,1)-pizda(1,2)
10493       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10494       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10495 ! Cartesian derivatives.
10496       do iii=1,2
10497         do kkk=1,5
10498           do lll=1,3
10499 #ifdef MOMENT
10500             if (iii.eq.1) then
10501               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10502             else
10503               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10504             endif
10505 #endif
10506             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10507               auxvec(1))
10508             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10509             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10510               auxvec(1))
10511             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10512             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10513               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),Ctobr(1,k))
10517 #ifdef MOMENT
10518             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10519 #else
10520             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10521 #endif
10522             if (swap) then
10523               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10524             else
10525               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10526             endif
10527 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10528           enddo
10529         enddo
10530       enddo
10531       return
10532       end function eello6_graph3
10533 !-----------------------------------------------------------------------------
10534       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10535 !      implicit real*8 (a-h,o-z)
10536 !      include 'DIMENSIONS'
10537 !      include 'COMMON.IOUNITS'
10538 !      include 'COMMON.CHAIN'
10539 !      include 'COMMON.DERIV'
10540 !      include 'COMMON.INTERACT'
10541 !      include 'COMMON.CONTACTS'
10542 !      include 'COMMON.TORSION'
10543 !      include 'COMMON.VAR'
10544 !      include 'COMMON.GEO'
10545 !      include 'COMMON.FFIELD'
10546       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10547       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10548       logical :: swap
10549       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10550               iii,kkk,lll
10551       real(kind=8) :: s1,s2,s3,s4
10552 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10553 !                                                                              C
10554 !      Parallel       Antiparallel                                             C
10555 !                                                                              C
10556 !          o             o                                                     C
10557 !         /l\   /   \   /j\                                                    C
10558 !        /   \ /     \ /   \                                                   C
10559 !       /| o |o       o| o |\                                                  C
10560 !     \ j|/k\|      \  |/k\|l                                                  C
10561 !      \ /   \       \ /   \                                                   C
10562 !       o     \       o     \                                                  C
10563 !       i             i                                                        C
10564 !                                                                              C
10565 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10566 !
10567 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10568 !           energy moment and not to the cluster cumulant.
10569 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10570       iti=itortyp(itype(i,1))
10571       itj=itortyp(itype(j,1))
10572       if (j.lt.nres-1) then
10573         itj1=itortyp(itype(j+1,1))
10574       else
10575         itj1=ntortyp+1
10576       endif
10577       itk=itortyp(itype(k,1))
10578       if (k.lt.nres-1) then
10579         itk1=itortyp(itype(k+1,1))
10580       else
10581         itk1=ntortyp+1
10582       endif
10583       itl=itortyp(itype(l,1))
10584       if (l.lt.nres-1) then
10585         itl1=itortyp(itype(l+1,1))
10586       else
10587         itl1=ntortyp+1
10588       endif
10589 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10590 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10591 !d     & ' itl',itl,' itl1',itl1
10592 #ifdef MOMENT
10593       if (imat.eq.1) then
10594         s1=dip(3,jj,i)*dip(3,kk,k)
10595       else
10596         s1=dip(2,jj,j)*dip(2,kk,l)
10597       endif
10598 #endif
10599       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10600       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10601       if (j.eq.l+1) then
10602         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10603         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10604       else
10605         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10606         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10607       endif
10608       call transpose2(EUg(1,1,k),auxmat(1,1))
10609       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10610       vv(1)=pizda(1,1)-pizda(2,2)
10611       vv(2)=pizda(2,1)+pizda(1,2)
10612       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10613 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10614 #ifdef MOMENT
10615       eello6_graph4=-(s1+s2+s3+s4)
10616 #else
10617       eello6_graph4=-(s2+s3+s4)
10618 #endif
10619 ! Derivatives in gamma(i-1)
10620       if (i.gt.1) then
10621 #ifdef MOMENT
10622         if (imat.eq.1) then
10623           s1=dipderg(2,jj,i)*dip(3,kk,k)
10624         else
10625           s1=dipderg(4,jj,j)*dip(2,kk,l)
10626         endif
10627 #endif
10628         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10629         if (j.eq.l+1) then
10630           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10631           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10632         else
10633           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10634           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10635         endif
10636         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10637         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10638 !d          write (2,*) 'turn6 derivatives'
10639 #ifdef MOMENT
10640           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10641 #else
10642           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10643 #endif
10644         else
10645 #ifdef MOMENT
10646           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10647 #else
10648           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10649 #endif
10650         endif
10651       endif
10652 ! Derivatives in gamma(k-1)
10653 #ifdef MOMENT
10654       if (imat.eq.1) then
10655         s1=dip(3,jj,i)*dipderg(2,kk,k)
10656       else
10657         s1=dip(2,jj,j)*dipderg(4,kk,l)
10658       endif
10659 #endif
10660       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10661       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10662       if (j.eq.l+1) then
10663         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10664         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10665       else
10666         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10667         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10668       endif
10669       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10670       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10671       vv(1)=pizda(1,1)-pizda(2,2)
10672       vv(2)=pizda(2,1)+pizda(1,2)
10673       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10674       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10675 #ifdef MOMENT
10676         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10677 #else
10678         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10679 #endif
10680       else
10681 #ifdef MOMENT
10682         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10683 #else
10684         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10685 #endif
10686       endif
10687 ! Derivatives in gamma(j-1) or gamma(l-1)
10688       if (l.eq.j+1 .and. l.gt.1) then
10689         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10690         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10691         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10692         vv(1)=pizda(1,1)-pizda(2,2)
10693         vv(2)=pizda(2,1)+pizda(1,2)
10694         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10695         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10696       else if (j.gt.1) then
10697         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10698         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10699         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10700         vv(1)=pizda(1,1)-pizda(2,2)
10701         vv(2)=pizda(2,1)+pizda(1,2)
10702         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10703         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10704           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10705         else
10706           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10707         endif
10708       endif
10709 ! Cartesian derivatives.
10710       do iii=1,2
10711         do kkk=1,5
10712           do lll=1,3
10713 #ifdef MOMENT
10714             if (iii.eq.1) then
10715               if (imat.eq.1) then
10716                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10717               else
10718                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10719               endif
10720             else
10721               if (imat.eq.1) then
10722                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10723               else
10724                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10725               endif
10726             endif
10727 #endif
10728             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10729               auxvec(1))
10730             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10731             if (j.eq.l+1) then
10732               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10733                 b1(1,itj1),auxvec(1))
10734               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10735             else
10736               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10737                 b1(1,itl1),auxvec(1))
10738               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10739             endif
10740             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10741               pizda(1,1))
10742             vv(1)=pizda(1,1)-pizda(2,2)
10743             vv(2)=pizda(2,1)+pizda(1,2)
10744             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10745             if (swap) then
10746               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10747 #ifdef MOMENT
10748                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10749                    -(s1+s2+s4)
10750 #else
10751                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10752                    -(s2+s4)
10753 #endif
10754                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10755               else
10756 #ifdef MOMENT
10757                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10758 #else
10759                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10760 #endif
10761                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10762               endif
10763             else
10764 #ifdef MOMENT
10765               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10766 #else
10767               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10768 #endif
10769               if (l.eq.j+1) then
10770                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10771               else
10772                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10773               endif
10774             endif
10775           enddo
10776         enddo
10777       enddo
10778       return
10779       end function eello6_graph4
10780 !-----------------------------------------------------------------------------
10781       real(kind=8) function eello_turn6(i,jj,kk)
10782 !      implicit real*8 (a-h,o-z)
10783 !      include 'DIMENSIONS'
10784 !      include 'COMMON.IOUNITS'
10785 !      include 'COMMON.CHAIN'
10786 !      include 'COMMON.DERIV'
10787 !      include 'COMMON.INTERACT'
10788 !      include 'COMMON.CONTACTS'
10789 !      include 'COMMON.TORSION'
10790 !      include 'COMMON.VAR'
10791 !      include 'COMMON.GEO'
10792       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10793       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10794       real(kind=8),dimension(3) :: ggg1,ggg2
10795       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10796       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10797 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10798 !           the respective energy moment and not to the cluster cumulant.
10799 !el local variables
10800       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10801       integer :: j1,j2,l1,l2,ll
10802       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10803       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10804       s1=0.0d0
10805       s8=0.0d0
10806       s13=0.0d0
10807 !
10808       eello_turn6=0.0d0
10809       j=i+4
10810       k=i+1
10811       l=i+3
10812       iti=itortyp(itype(i,1))
10813       itk=itortyp(itype(k,1))
10814       itk1=itortyp(itype(k+1,1))
10815       itl=itortyp(itype(l,1))
10816       itj=itortyp(itype(j,1))
10817 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10818 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10819 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10820 !d        eello6=0.0d0
10821 !d        return
10822 !d      endif
10823 !d      write (iout,*)
10824 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10825 !d     &   ' and',k,l
10826 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10827       do iii=1,2
10828         do kkk=1,5
10829           do lll=1,3
10830             derx_turn(lll,kkk,iii)=0.0d0
10831           enddo
10832         enddo
10833       enddo
10834 !d      eij=1.0d0
10835 !d      ekl=1.0d0
10836 !d      ekont=1.0d0
10837       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10838 !d      eello6_5=0.0d0
10839 !d      write (2,*) 'eello6_5',eello6_5
10840 #ifdef MOMENT
10841       call transpose2(AEA(1,1,1),auxmat(1,1))
10842       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10843       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10844       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10845 #endif
10846       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10847       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10848       s2 = scalar2(b1(1,itk),vtemp1(1))
10849 #ifdef MOMENT
10850       call transpose2(AEA(1,1,2),atemp(1,1))
10851       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10852       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10853       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10854 #endif
10855       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10856       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10857       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10858 #ifdef MOMENT
10859       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10860       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10861       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10862       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10863       ss13 = scalar2(b1(1,itk),vtemp4(1))
10864       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10865 #endif
10866 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10867 !      s1=0.0d0
10868 !      s2=0.0d0
10869 !      s8=0.0d0
10870 !      s12=0.0d0
10871 !      s13=0.0d0
10872       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10873 ! Derivatives in gamma(i+2)
10874       s1d =0.0d0
10875       s8d =0.0d0
10876 #ifdef MOMENT
10877       call transpose2(AEA(1,1,1),auxmatd(1,1))
10878       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10879       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10880       call transpose2(AEAderg(1,1,2),atempd(1,1))
10881       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10882       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10883 #endif
10884       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10885       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10886       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10887 !      s1d=0.0d0
10888 !      s2d=0.0d0
10889 !      s8d=0.0d0
10890 !      s12d=0.0d0
10891 !      s13d=0.0d0
10892       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10893 ! Derivatives in gamma(i+3)
10894 #ifdef MOMENT
10895       call transpose2(AEA(1,1,1),auxmatd(1,1))
10896       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10897       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10898       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10899 #endif
10900       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10901       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10902       s2d = scalar2(b1(1,itk),vtemp1d(1))
10903 #ifdef MOMENT
10904       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10905       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10906 #endif
10907       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10908 #ifdef MOMENT
10909       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10910       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10911       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10912 #endif
10913 !      s1d=0.0d0
10914 !      s2d=0.0d0
10915 !      s8d=0.0d0
10916 !      s12d=0.0d0
10917 !      s13d=0.0d0
10918 #ifdef MOMENT
10919       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10920                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10921 #else
10922       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10923                     -0.5d0*ekont*(s2d+s12d)
10924 #endif
10925 ! Derivatives in gamma(i+4)
10926       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10927       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10928       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10929 #ifdef MOMENT
10930       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10931       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10932       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10933 #endif
10934 !      s1d=0.0d0
10935 !      s2d=0.0d0
10936 !      s8d=0.0d0
10937 !      s12d=0.0d0
10938 !      s13d=0.0d0
10939 #ifdef MOMENT
10940       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10941 #else
10942       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10943 #endif
10944 ! Derivatives in gamma(i+5)
10945 #ifdef MOMENT
10946       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10947       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10948       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10949 #endif
10950       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10951       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10952       s2d = scalar2(b1(1,itk),vtemp1d(1))
10953 #ifdef MOMENT
10954       call transpose2(AEA(1,1,2),atempd(1,1))
10955       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10956       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10957 #endif
10958       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10959       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10960 #ifdef MOMENT
10961       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10962       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10963       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10964 #endif
10965 !      s1d=0.0d0
10966 !      s2d=0.0d0
10967 !      s8d=0.0d0
10968 !      s12d=0.0d0
10969 !      s13d=0.0d0
10970 #ifdef MOMENT
10971       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10972                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10973 #else
10974       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10975                     -0.5d0*ekont*(s2d+s12d)
10976 #endif
10977 ! Cartesian derivatives
10978       do iii=1,2
10979         do kkk=1,5
10980           do lll=1,3
10981 #ifdef MOMENT
10982             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10983             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10984             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10985 #endif
10986             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10987             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10988                 vtemp1d(1))
10989             s2d = scalar2(b1(1,itk),vtemp1d(1))
10990 #ifdef MOMENT
10991             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10992             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10993             s8d = -(atempd(1,1)+atempd(2,2))* &
10994                  scalar2(cc(1,1,itl),vtemp2(1))
10995 #endif
10996             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10997                  auxmatd(1,1))
10998             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10999             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11000 !      s1d=0.0d0
11001 !      s2d=0.0d0
11002 !      s8d=0.0d0
11003 !      s12d=0.0d0
11004 !      s13d=0.0d0
11005 #ifdef MOMENT
11006             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11007               - 0.5d0*(s1d+s2d)
11008 #else
11009             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11010               - 0.5d0*s2d
11011 #endif
11012 #ifdef MOMENT
11013             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11014               - 0.5d0*(s8d+s12d)
11015 #else
11016             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11017               - 0.5d0*s12d
11018 #endif
11019           enddo
11020         enddo
11021       enddo
11022 #ifdef MOMENT
11023       do kkk=1,5
11024         do lll=1,3
11025           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
11026             achuj_tempd(1,1))
11027           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11028           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11029           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11030           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11031           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
11032             vtemp4d(1))
11033           ss13d = scalar2(b1(1,itk),vtemp4d(1))
11034           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11035           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11036         enddo
11037       enddo
11038 #endif
11039 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11040 !d     &  16*eel_turn6_num
11041 !d      goto 1112
11042       if (j.lt.nres-1) then
11043         j1=j+1
11044         j2=j-1
11045       else
11046         j1=j-1
11047         j2=j-2
11048       endif
11049       if (l.lt.nres-1) then
11050         l1=l+1
11051         l2=l-1
11052       else
11053         l1=l-1
11054         l2=l-2
11055       endif
11056       do ll=1,3
11057 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11058 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11059 !grad        ghalf=0.5d0*ggg1(ll)
11060 !d        ghalf=0.0d0
11061         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11062         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11063         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11064           +ekont*derx_turn(ll,2,1)
11065         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11066         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11067           +ekont*derx_turn(ll,4,1)
11068         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11069         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11070         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11071 !grad        ghalf=0.5d0*ggg2(ll)
11072 !d        ghalf=0.0d0
11073         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11074           +ekont*derx_turn(ll,2,2)
11075         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11076         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11077           +ekont*derx_turn(ll,4,2)
11078         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11079         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11080         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11081       enddo
11082 !d      goto 1112
11083 !grad      do m=i+1,j-1
11084 !grad        do ll=1,3
11085 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11086 !grad        enddo
11087 !grad      enddo
11088 !grad      do m=k+1,l-1
11089 !grad        do ll=1,3
11090 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11091 !grad        enddo
11092 !grad      enddo
11093 !grad1112  continue
11094 !grad      do m=i+2,j2
11095 !grad        do ll=1,3
11096 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11097 !grad        enddo
11098 !grad      enddo
11099 !grad      do m=k+2,l2
11100 !grad        do ll=1,3
11101 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11102 !grad        enddo
11103 !grad      enddo
11104 !d      do iii=1,nres-3
11105 !d        write (2,*) iii,g_corr6_loc(iii)
11106 !d      enddo
11107       eello_turn6=ekont*eel_turn6
11108 !d      write (2,*) 'ekont',ekont
11109 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11110       return
11111       end function eello_turn6
11112 !-----------------------------------------------------------------------------
11113       subroutine MATVEC2(A1,V1,V2)
11114 !DIR$ INLINEALWAYS MATVEC2
11115 #ifndef OSF
11116 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11117 #endif
11118 !      implicit real*8 (a-h,o-z)
11119 !      include 'DIMENSIONS'
11120       real(kind=8),dimension(2) :: V1,V2
11121       real(kind=8),dimension(2,2) :: A1
11122       real(kind=8) :: vaux1,vaux2
11123 !      DO 1 I=1,2
11124 !        VI=0.0
11125 !        DO 3 K=1,2
11126 !    3     VI=VI+A1(I,K)*V1(K)
11127 !        Vaux(I)=VI
11128 !    1 CONTINUE
11129
11130       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11131       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11132
11133       v2(1)=vaux1
11134       v2(2)=vaux2
11135       end subroutine MATVEC2
11136 !-----------------------------------------------------------------------------
11137       subroutine MATMAT2(A1,A2,A3)
11138 #ifndef OSF
11139 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11140 #endif
11141 !      implicit real*8 (a-h,o-z)
11142 !      include 'DIMENSIONS'
11143       real(kind=8),dimension(2,2) :: A1,A2,A3
11144       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11145 !      DIMENSION AI3(2,2)
11146 !        DO  J=1,2
11147 !          A3IJ=0.0
11148 !          DO K=1,2
11149 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11150 !          enddo
11151 !          A3(I,J)=A3IJ
11152 !       enddo
11153 !      enddo
11154
11155       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11156       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11157       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11158       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11159
11160       A3(1,1)=AI3_11
11161       A3(2,1)=AI3_21
11162       A3(1,2)=AI3_12
11163       A3(2,2)=AI3_22
11164       end subroutine MATMAT2
11165 !-----------------------------------------------------------------------------
11166       real(kind=8) function scalar2(u,v)
11167 !DIR$ INLINEALWAYS scalar2
11168       implicit none
11169       real(kind=8),dimension(2) :: u,v
11170       real(kind=8) :: sc
11171       integer :: i
11172       scalar2=u(1)*v(1)+u(2)*v(2)
11173       return
11174       end function scalar2
11175 !-----------------------------------------------------------------------------
11176       subroutine transpose2(a,at)
11177 !DIR$ INLINEALWAYS transpose2
11178 #ifndef OSF
11179 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11180 #endif
11181       implicit none
11182       real(kind=8),dimension(2,2) :: a,at
11183       at(1,1)=a(1,1)
11184       at(1,2)=a(2,1)
11185       at(2,1)=a(1,2)
11186       at(2,2)=a(2,2)
11187       return
11188       end subroutine transpose2
11189 !-----------------------------------------------------------------------------
11190       subroutine transpose(n,a,at)
11191       implicit none
11192       integer :: n,i,j
11193       real(kind=8),dimension(n,n) :: a,at
11194       do i=1,n
11195         do j=1,n
11196           at(j,i)=a(i,j)
11197         enddo
11198       enddo
11199       return
11200       end subroutine transpose
11201 !-----------------------------------------------------------------------------
11202       subroutine prodmat3(a1,a2,kk,transp,prod)
11203 !DIR$ INLINEALWAYS prodmat3
11204 #ifndef OSF
11205 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11206 #endif
11207       implicit none
11208       integer :: i,j
11209       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11210       logical :: transp
11211 !rc      double precision auxmat(2,2),prod_(2,2)
11212
11213       if (transp) then
11214 !rc        call transpose2(kk(1,1),auxmat(1,1))
11215 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11216 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11217
11218            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11219        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11220            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11221        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11222            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11223        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11224            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11225        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11226
11227       else
11228 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11229 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11230
11231            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11232         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11233            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11234         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11235            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11236         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11237            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11238         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11239
11240       endif
11241 !      call transpose2(a2(1,1),a2t(1,1))
11242
11243 !rc      print *,transp
11244 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11245 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11246
11247       return
11248       end subroutine prodmat3
11249 !-----------------------------------------------------------------------------
11250 ! energy_p_new_barrier.F
11251 !-----------------------------------------------------------------------------
11252       subroutine sum_gradient
11253 !      implicit real*8 (a-h,o-z)
11254       use io_base, only: pdbout
11255 !      include 'DIMENSIONS'
11256 #ifndef ISNAN
11257       external proc_proc
11258 #ifdef WINPGI
11259 !MS$ATTRIBUTES C ::  proc_proc
11260 #endif
11261 #endif
11262 #ifdef MPI
11263       include 'mpif.h'
11264 #endif
11265       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11266                    gloc_scbuf !(3,maxres)
11267
11268       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11269 !#endif
11270 !el local variables
11271       integer :: i,j,k,ierror,ierr
11272       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11273                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11274                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11275                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11276                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11277                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11278                    gsccorr_max,gsccorrx_max,time00
11279
11280 !      include 'COMMON.SETUP'
11281 !      include 'COMMON.IOUNITS'
11282 !      include 'COMMON.FFIELD'
11283 !      include 'COMMON.DERIV'
11284 !      include 'COMMON.INTERACT'
11285 !      include 'COMMON.SBRIDGE'
11286 !      include 'COMMON.CHAIN'
11287 !      include 'COMMON.VAR'
11288 !      include 'COMMON.CONTROL'
11289 !      include 'COMMON.TIME1'
11290 !      include 'COMMON.MAXGRAD'
11291 !      include 'COMMON.SCCOR'
11292 #ifdef TIMING
11293       time01=MPI_Wtime()
11294 #endif
11295 !#define DEBUG
11296 #ifdef DEBUG
11297       write (iout,*) "sum_gradient gvdwc, gvdwx"
11298       do i=1,nres
11299         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11300          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11301       enddo
11302       call flush(iout)
11303 #endif
11304 #ifdef MPI
11305         gradbufc=0.0d0
11306         gradbufx=0.0d0
11307         gradbufc_sum=0.0d0
11308         gloc_scbuf=0.0d0
11309         glocbuf=0.0d0
11310 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11311         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11312           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11313 #endif
11314 !
11315 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11316 !            in virtual-bond-vector coordinates
11317 !
11318 #ifdef DEBUG
11319 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11320 !      do i=1,nres-1
11321 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11322 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11323 !      enddo
11324 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11325 !      do i=1,nres-1
11326 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11327 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11328 !      enddo
11329 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11330 !      do i=1,nres
11331 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11332 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11333 !         (gvdwc_scpp(j,i),j=1,3)
11334 !      enddo
11335 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11336 !      do i=1,nres
11337 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11338 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11339 !         (gelc_loc_long(j,i),j=1,3)
11340 !      enddo
11341       call flush(iout)
11342 #endif
11343 #ifdef SPLITELE
11344       do i=0,nct
11345         do j=1,3
11346           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11347                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11348                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11349                       wel_loc*gel_loc_long(j,i)+ &
11350                       wcorr*gradcorr_long(j,i)+ &
11351                       wcorr5*gradcorr5_long(j,i)+ &
11352                       wcorr6*gradcorr6_long(j,i)+ &
11353                       wturn6*gcorr6_turn_long(j,i)+ &
11354                       wstrain*ghpbc(j,i) &
11355                      +wliptran*gliptranc(j,i) &
11356                      +gradafm(j,i) &
11357                      +welec*gshieldc(j,i) &
11358                      +wcorr*gshieldc_ec(j,i) &
11359                      +wturn3*gshieldc_t3(j,i)&
11360                      +wturn4*gshieldc_t4(j,i)&
11361                      +wel_loc*gshieldc_ll(j,i)&
11362                      +wtube*gg_tube(j,i) &
11363                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11364                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11365                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11366                      wcorr_nucl*gradcorr_nucl(j,i)&
11367                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11368                      wcatprot* gradpepcat(j,i)+ &
11369                      wcatcat*gradcatcat(j,i)+   &
11370                      wscbase*gvdwc_scbase(j,i)+ &
11371                      wpepbase*gvdwc_pepbase(j,i)+&
11372                      wscpho*gvdwc_scpho(j,i)+   &
11373                      wpeppho*gvdwc_peppho(j,i)
11374
11375
11376
11377
11378
11379         enddo
11380       enddo
11381 #else
11382       do i=0,nct
11383         do j=1,3
11384           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11385                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11386                       welec*gelc_long(j,i)+ &
11387                       wbond*gradb(j,i)+ &
11388                       wel_loc*gel_loc_long(j,i)+ &
11389                       wcorr*gradcorr_long(j,i)+ &
11390                       wcorr5*gradcorr5_long(j,i)+ &
11391                       wcorr6*gradcorr6_long(j,i)+ &
11392                       wturn6*gcorr6_turn_long(j,i)+ &
11393                       wstrain*ghpbc(j,i) &
11394                      +wliptran*gliptranc(j,i) &
11395                      +gradafm(j,i) &
11396                      +welec*gshieldc(j,i)&
11397                      +wcorr*gshieldc_ec(j,i) &
11398                      +wturn4*gshieldc_t4(j,i) &
11399                      +wel_loc*gshieldc_ll(j,i)&
11400                      +wtube*gg_tube(j,i) &
11401                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11402                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11403                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11404                      wcorr_nucl*gradcorr_nucl(j,i) &
11405                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11406                      wcatprot* gradpepcat(j,i)+ &
11407                      wcatcat*gradcatcat(j,i)+   &
11408                      wscbase*gvdwc_scbase(j,i)+ &
11409                      wpepbase*gvdwc_pepbase(j,i)+&
11410                      wscpho*gvdwc_scpho(j,i)+&
11411                      wpeppho*gvdwc_peppho(j,i)
11412
11413
11414         enddo
11415       enddo
11416 #endif
11417 #ifdef MPI
11418       if (nfgtasks.gt.1) then
11419       time00=MPI_Wtime()
11420 #ifdef DEBUG
11421       write (iout,*) "gradbufc before allreduce"
11422       do i=1,nres
11423         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11424       enddo
11425       call flush(iout)
11426 #endif
11427       do i=0,nres
11428         do j=1,3
11429           gradbufc_sum(j,i)=gradbufc(j,i)
11430         enddo
11431       enddo
11432 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11433 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11434 !      time_reduce=time_reduce+MPI_Wtime()-time00
11435 #ifdef DEBUG
11436 !      write (iout,*) "gradbufc_sum after allreduce"
11437 !      do i=1,nres
11438 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11439 !      enddo
11440 !      call flush(iout)
11441 #endif
11442 #ifdef TIMING
11443 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11444 #endif
11445       do i=0,nres
11446         do k=1,3
11447           gradbufc(k,i)=0.0d0
11448         enddo
11449       enddo
11450 #ifdef DEBUG
11451       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11452       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11453                         " jgrad_end  ",jgrad_end(i),&
11454                         i=igrad_start,igrad_end)
11455 #endif
11456 !
11457 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11458 ! do not parallelize this part.
11459 !
11460 !      do i=igrad_start,igrad_end
11461 !        do j=jgrad_start(i),jgrad_end(i)
11462 !          do k=1,3
11463 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11464 !          enddo
11465 !        enddo
11466 !      enddo
11467       do j=1,3
11468         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11469       enddo
11470       do i=nres-2,-1,-1
11471         do j=1,3
11472           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11473         enddo
11474       enddo
11475 #ifdef DEBUG
11476       write (iout,*) "gradbufc after summing"
11477       do i=1,nres
11478         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11479       enddo
11480       call flush(iout)
11481 #endif
11482       else
11483 #endif
11484 !el#define DEBUG
11485 #ifdef DEBUG
11486       write (iout,*) "gradbufc"
11487       do i=1,nres
11488         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11489       enddo
11490       call flush(iout)
11491 #endif
11492 !el#undef DEBUG
11493       do i=-1,nres
11494         do j=1,3
11495           gradbufc_sum(j,i)=gradbufc(j,i)
11496           gradbufc(j,i)=0.0d0
11497         enddo
11498       enddo
11499       do j=1,3
11500         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11501       enddo
11502       do i=nres-2,-1,-1
11503         do j=1,3
11504           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11505         enddo
11506       enddo
11507 !      do i=nnt,nres-1
11508 !        do k=1,3
11509 !          gradbufc(k,i)=0.0d0
11510 !        enddo
11511 !        do j=i+1,nres
11512 !          do k=1,3
11513 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11514 !          enddo
11515 !        enddo
11516 !      enddo
11517 !el#define DEBUG
11518 #ifdef DEBUG
11519       write (iout,*) "gradbufc after summing"
11520       do i=1,nres
11521         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11522       enddo
11523       call flush(iout)
11524 #endif
11525 !el#undef DEBUG
11526 #ifdef MPI
11527       endif
11528 #endif
11529       do k=1,3
11530         gradbufc(k,nres)=0.0d0
11531       enddo
11532 !el----------------
11533 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11534 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11535 !el-----------------
11536       do i=-1,nct
11537         do j=1,3
11538 #ifdef SPLITELE
11539           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11540                       wel_loc*gel_loc(j,i)+ &
11541                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11542                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11543                       wel_loc*gel_loc_long(j,i)+ &
11544                       wcorr*gradcorr_long(j,i)+ &
11545                       wcorr5*gradcorr5_long(j,i)+ &
11546                       wcorr6*gradcorr6_long(j,i)+ &
11547                       wturn6*gcorr6_turn_long(j,i))+ &
11548                       wbond*gradb(j,i)+ &
11549                       wcorr*gradcorr(j,i)+ &
11550                       wturn3*gcorr3_turn(j,i)+ &
11551                       wturn4*gcorr4_turn(j,i)+ &
11552                       wcorr5*gradcorr5(j,i)+ &
11553                       wcorr6*gradcorr6(j,i)+ &
11554                       wturn6*gcorr6_turn(j,i)+ &
11555                       wsccor*gsccorc(j,i) &
11556                      +wscloc*gscloc(j,i)  &
11557                      +wliptran*gliptranc(j,i) &
11558                      +gradafm(j,i) &
11559                      +welec*gshieldc(j,i) &
11560                      +welec*gshieldc_loc(j,i) &
11561                      +wcorr*gshieldc_ec(j,i) &
11562                      +wcorr*gshieldc_loc_ec(j,i) &
11563                      +wturn3*gshieldc_t3(j,i) &
11564                      +wturn3*gshieldc_loc_t3(j,i) &
11565                      +wturn4*gshieldc_t4(j,i) &
11566                      +wturn4*gshieldc_loc_t4(j,i) &
11567                      +wel_loc*gshieldc_ll(j,i) &
11568                      +wel_loc*gshieldc_loc_ll(j,i) &
11569                      +wtube*gg_tube(j,i) &
11570                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11571                      +wvdwpsb*gvdwpsb1(j,i))&
11572                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11573 !                      if (i.eq.21) then
11574 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11575 !                      wturn4*gshieldc_t4(j,i), &
11576 !                     wturn4*gshieldc_loc_t4(j,i)
11577 !                       endif
11578 !                 if ((i.le.2).and.(i.ge.1))
11579 !                       print *,gradc(j,i,icg),&
11580 !                      gradbufc(j,i),welec*gelc(j,i), &
11581 !                      wel_loc*gel_loc(j,i), &
11582 !                      wscp*gvdwc_scpp(j,i), &
11583 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11584 !                      wel_loc*gel_loc_long(j,i), &
11585 !                      wcorr*gradcorr_long(j,i), &
11586 !                      wcorr5*gradcorr5_long(j,i), &
11587 !                      wcorr6*gradcorr6_long(j,i), &
11588 !                      wturn6*gcorr6_turn_long(j,i), &
11589 !                      wbond*gradb(j,i), &
11590 !                      wcorr*gradcorr(j,i), &
11591 !                      wturn3*gcorr3_turn(j,i), &
11592 !                      wturn4*gcorr4_turn(j,i), &
11593 !                      wcorr5*gradcorr5(j,i), &
11594 !                      wcorr6*gradcorr6(j,i), &
11595 !                      wturn6*gcorr6_turn(j,i), &
11596 !                      wsccor*gsccorc(j,i) &
11597 !                     ,wscloc*gscloc(j,i)  &
11598 !                     ,wliptran*gliptranc(j,i) &
11599 !                    ,gradafm(j,i) &
11600 !                     ,welec*gshieldc(j,i) &
11601 !                     ,welec*gshieldc_loc(j,i) &
11602 !                     ,wcorr*gshieldc_ec(j,i) &
11603 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11604 !                     ,wturn3*gshieldc_t3(j,i) &
11605 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11606 !                     ,wturn4*gshieldc_t4(j,i) &
11607 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11608 !                     ,wel_loc*gshieldc_ll(j,i) &
11609 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11610 !                     ,wtube*gg_tube(j,i) &
11611 !                     ,wbond_nucl*gradb_nucl(j,i) &
11612 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11613 !                     wvdwpsb*gvdwpsb1(j,i)&
11614 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11615 !
11616
11617 #else
11618           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11619                       wel_loc*gel_loc(j,i)+ &
11620                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11621                       welec*gelc_long(j,i)+ &
11622                       wel_loc*gel_loc_long(j,i)+ &
11623 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11624                       wcorr5*gradcorr5_long(j,i)+ &
11625                       wcorr6*gradcorr6_long(j,i)+ &
11626                       wturn6*gcorr6_turn_long(j,i))+ &
11627                       wbond*gradb(j,i)+ &
11628                       wcorr*gradcorr(j,i)+ &
11629                       wturn3*gcorr3_turn(j,i)+ &
11630                       wturn4*gcorr4_turn(j,i)+ &
11631                       wcorr5*gradcorr5(j,i)+ &
11632                       wcorr6*gradcorr6(j,i)+ &
11633                       wturn6*gcorr6_turn(j,i)+ &
11634                       wsccor*gsccorc(j,i) &
11635                      +wscloc*gscloc(j,i) &
11636                      +gradafm(j,i) &
11637                      +wliptran*gliptranc(j,i) &
11638                      +welec*gshieldc(j,i) &
11639                      +welec*gshieldc_loc(j,i) &
11640                      +wcorr*gshieldc_ec(j,i) &
11641                      +wcorr*gshieldc_loc_ec(j,i) &
11642                      +wturn3*gshieldc_t3(j,i) &
11643                      +wturn3*gshieldc_loc_t3(j,i) &
11644                      +wturn4*gshieldc_t4(j,i) &
11645                      +wturn4*gshieldc_loc_t4(j,i) &
11646                      +wel_loc*gshieldc_ll(j,i) &
11647                      +wel_loc*gshieldc_loc_ll(j,i) &
11648                      +wtube*gg_tube(j,i) &
11649                      +wbond_nucl*gradb_nucl(j,i) &
11650                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11651                      +wvdwpsb*gvdwpsb1(j,i))&
11652                      +wsbloc*gsbloc(j,i)
11653
11654
11655
11656
11657 #endif
11658           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11659                         wbond*gradbx(j,i)+ &
11660                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11661                         wsccor*gsccorx(j,i) &
11662                        +wscloc*gsclocx(j,i) &
11663                        +wliptran*gliptranx(j,i) &
11664                        +welec*gshieldx(j,i)     &
11665                        +wcorr*gshieldx_ec(j,i)  &
11666                        +wturn3*gshieldx_t3(j,i) &
11667                        +wturn4*gshieldx_t4(j,i) &
11668                        +wel_loc*gshieldx_ll(j,i)&
11669                        +wtube*gg_tube_sc(j,i)   &
11670                        +wbond_nucl*gradbx_nucl(j,i) &
11671                        +wvdwsb*gvdwsbx(j,i) &
11672                        +welsb*gelsbx(j,i) &
11673                        +wcorr_nucl*gradxorr_nucl(j,i)&
11674                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11675                        +wsbloc*gsblocx(j,i) &
11676                        +wcatprot* gradpepcatx(j,i)&
11677                        +wscbase*gvdwx_scbase(j,i) &
11678                        +wpepbase*gvdwx_pepbase(j,i)&
11679                        +wscpho*gvdwx_scpho(j,i)
11680 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11681
11682         enddo
11683       enddo
11684 !#define DEBUG
11685 #ifdef DEBUG
11686       write (iout,*) "gloc before adding corr"
11687       do i=1,4*nres
11688         write (iout,*) i,gloc(i,icg)
11689       enddo
11690 #endif
11691       do i=1,nres-3
11692         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11693          +wcorr5*g_corr5_loc(i) &
11694          +wcorr6*g_corr6_loc(i) &
11695          +wturn4*gel_loc_turn4(i) &
11696          +wturn3*gel_loc_turn3(i) &
11697          +wturn6*gel_loc_turn6(i) &
11698          +wel_loc*gel_loc_loc(i)
11699       enddo
11700 #ifdef DEBUG
11701       write (iout,*) "gloc after adding corr"
11702       do i=1,4*nres
11703         write (iout,*) i,gloc(i,icg)
11704       enddo
11705 #endif
11706 !#undef DEBUG
11707 #ifdef MPI
11708       if (nfgtasks.gt.1) then
11709         do j=1,3
11710           do i=0,nres
11711             gradbufc(j,i)=gradc(j,i,icg)
11712             gradbufx(j,i)=gradx(j,i,icg)
11713           enddo
11714         enddo
11715         do i=1,4*nres
11716           glocbuf(i)=gloc(i,icg)
11717         enddo
11718 !#define DEBUG
11719 #ifdef DEBUG
11720       write (iout,*) "gloc_sc before reduce"
11721       do i=1,nres
11722        do j=1,1
11723         write (iout,*) i,j,gloc_sc(j,i,icg)
11724        enddo
11725       enddo
11726 #endif
11727 !#undef DEBUG
11728         do i=0,nres
11729          do j=1,3
11730           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11731          enddo
11732         enddo
11733         time00=MPI_Wtime()
11734         call MPI_Barrier(FG_COMM,IERR)
11735         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11736         time00=MPI_Wtime()
11737         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11738           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11739         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11740           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11741         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11742           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11743         time_reduce=time_reduce+MPI_Wtime()-time00
11744         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
11745           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11746         time_reduce=time_reduce+MPI_Wtime()-time00
11747 !#define DEBUG
11748 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11749 #ifdef DEBUG
11750       write (iout,*) "gloc_sc after reduce"
11751       do i=0,nres
11752        do j=1,1
11753         write (iout,*) i,j,gloc_sc(j,i,icg)
11754        enddo
11755       enddo
11756 #endif
11757 !#undef DEBUG
11758 #ifdef DEBUG
11759       write (iout,*) "gloc after reduce"
11760       do i=1,4*nres
11761         write (iout,*) i,gloc(i,icg)
11762       enddo
11763 #endif
11764       endif
11765 #endif
11766       if (gnorm_check) then
11767 !
11768 ! Compute the maximum elements of the gradient
11769 !
11770       gvdwc_max=0.0d0
11771       gvdwc_scp_max=0.0d0
11772       gelc_max=0.0d0
11773       gvdwpp_max=0.0d0
11774       gradb_max=0.0d0
11775       ghpbc_max=0.0d0
11776       gradcorr_max=0.0d0
11777       gel_loc_max=0.0d0
11778       gcorr3_turn_max=0.0d0
11779       gcorr4_turn_max=0.0d0
11780       gradcorr5_max=0.0d0
11781       gradcorr6_max=0.0d0
11782       gcorr6_turn_max=0.0d0
11783       gsccorc_max=0.0d0
11784       gscloc_max=0.0d0
11785       gvdwx_max=0.0d0
11786       gradx_scp_max=0.0d0
11787       ghpbx_max=0.0d0
11788       gradxorr_max=0.0d0
11789       gsccorx_max=0.0d0
11790       gsclocx_max=0.0d0
11791       do i=1,nct
11792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11795         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11796          gvdwc_scp_max=gvdwc_scp_norm
11797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11810           gcorr3_turn(1,i)))
11811         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11812           gcorr3_turn_max=gcorr3_turn_norm
11813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11814           gcorr4_turn(1,i)))
11815         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11816           gcorr4_turn_max=gcorr4_turn_norm
11817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11818         if (gradcorr5_norm.gt.gradcorr5_max) &
11819           gradcorr5_max=gradcorr5_norm
11820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11823           gcorr6_turn(1,i)))
11824         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11825           gcorr6_turn_max=gcorr6_turn_norm
11826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11833         if (gradx_scp_norm.gt.gradx_scp_max) &
11834           gradx_scp_max=gradx_scp_norm
11835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11843       enddo
11844       if (gradout) then
11845 #ifdef AIX
11846         open(istat,file=statname,position="append")
11847 #else
11848         open(istat,file=statname,access="append")
11849 #endif
11850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11851            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11852            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11853            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11854            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11855            gsccorx_max,gsclocx_max
11856         close(istat)
11857         if (gvdwc_max.gt.1.0d4) then
11858           write (iout,*) "gvdwc gvdwx gradb gradbx"
11859           do i=nnt,nct
11860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11861               gradb(j,i),gradbx(j,i),j=1,3)
11862           enddo
11863           call pdbout(0.0d0,'cipiszcze',iout)
11864           call flush(iout)
11865         endif
11866       endif
11867       endif
11868 !#define DEBUG
11869 #ifdef DEBUG
11870       write (iout,*) "gradc gradx gloc"
11871       do i=1,nres
11872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11873          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11874       enddo
11875 #endif
11876 !#undef DEBUG
11877 #ifdef TIMING
11878       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11879 #endif
11880       return
11881       end subroutine sum_gradient
11882 !-----------------------------------------------------------------------------
11883       subroutine sc_grad
11884 !      implicit real*8 (a-h,o-z)
11885       use calc_data
11886 !      include 'DIMENSIONS'
11887 !      include 'COMMON.CHAIN'
11888 !      include 'COMMON.DERIV'
11889 !      include 'COMMON.CALC'
11890 !      include 'COMMON.IOUNITS'
11891       real(kind=8), dimension(3) :: dcosom1,dcosom2
11892 !      print *,"wchodze"
11893       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11894           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11895       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11896           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11897
11898       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11899            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11900            +dCAVdOM12+ dGCLdOM12
11901 ! diagnostics only
11902 !      eom1=0.0d0
11903 !      eom2=0.0d0
11904 !      eom12=evdwij*eps1_om12
11905 ! end diagnostics
11906 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11907 !       " sigder",sigder
11908 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11909 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11910 !C      print *,sss_ele_cut,'in sc_grad'
11911       do k=1,3
11912         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11913         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11914       enddo
11915       do k=1,3
11916         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11917 !C      print *,'gg',k,gg(k)
11918        enddo
11919 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11920 !      write (iout,*) "gg",(gg(k),k=1,3)
11921       do k=1,3
11922         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11923                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11924                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11925                   *sss_ele_cut
11926
11927         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11928                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11929                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11930                   *sss_ele_cut
11931
11932 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11933 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11934 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11935 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11936       enddo
11937 !
11938 ! Calculate the components of the gradient in DC and X
11939 !
11940 !grad      do k=i,j-1
11941 !grad        do l=1,3
11942 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11943 !grad        enddo
11944 !grad      enddo
11945       do l=1,3
11946         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11947         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11948       enddo
11949       return
11950       end subroutine sc_grad
11951
11952       subroutine sc_grad_cat
11953       use calc_data
11954       real(kind=8), dimension(3) :: dcosom1,dcosom2
11955       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11956           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11957       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11958           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11959
11960       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11961            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11962            +dCAVdOM12+ dGCLdOM12
11963 ! diagnostics only
11964 !      eom1=0.0d0
11965 !      eom2=0.0d0
11966 !      eom12=evdwij*eps1_om12
11967 ! end diagnostics
11968
11969       do k=1,3
11970         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11971         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11972       enddo
11973       do k=1,3
11974         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11975 !C      print *,'gg',k,gg(k)
11976        enddo
11977 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11978 !      write (iout,*) "gg",(gg(k),k=1,3)
11979       do k=1,3
11980         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11981                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11982                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11983
11984 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11985 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11986 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11987
11988 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11989 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11990 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11991 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11992       enddo
11993 !
11994 ! Calculate the components of the gradient in DC and X
11995 !
11996       do l=1,3
11997         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11998         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11999       enddo
12000       end subroutine sc_grad_cat
12001
12002       subroutine sc_grad_cat_pep
12003       use calc_data
12004       real(kind=8), dimension(3) :: dcosom1,dcosom2
12005       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12006           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12007       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12008           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12009
12010       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12011            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12012            +dCAVdOM12+ dGCLdOM12
12013 ! diagnostics only
12014 !      eom1=0.0d0
12015 !      eom2=0.0d0
12016 !      eom12=evdwij*eps1_om12
12017 ! end diagnostics
12018
12019       do k=1,3
12020         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12021         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12022         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12023         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
12024                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12025                  *dsci_inv*2.0 &
12026                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12027         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
12028                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12029                  *dsci_inv*2.0 &
12030                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12031         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
12032       enddo
12033       end subroutine sc_grad_cat_pep
12034
12035 #ifdef CRYST_THETA
12036 !-----------------------------------------------------------------------------
12037       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12038
12039       use comm_calcthet
12040 !      implicit real*8 (a-h,o-z)
12041 !      include 'DIMENSIONS'
12042 !      include 'COMMON.LOCAL'
12043 !      include 'COMMON.IOUNITS'
12044 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12045 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12046 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12047       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12048       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12049 !el      integer :: it
12050 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12051 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12052 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12053 !el local variables
12054
12055       delthec=thetai-thet_pred_mean
12056       delthe0=thetai-theta0i
12057 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12058       t3 = thetai-thet_pred_mean
12059       t6 = t3**2
12060       t9 = term1
12061       t12 = t3*sigcsq
12062       t14 = t12+t6*sigsqtc
12063       t16 = 1.0d0
12064       t21 = thetai-theta0i
12065       t23 = t21**2
12066       t26 = term2
12067       t27 = t21*t26
12068       t32 = termexp
12069       t40 = t32**2
12070       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12071        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12072        *(-t12*t9-ak*sig0inv*t27)
12073       return
12074       end subroutine mixder
12075 #endif
12076 !-----------------------------------------------------------------------------
12077 ! cartder.F
12078 !-----------------------------------------------------------------------------
12079       subroutine cartder
12080 !-----------------------------------------------------------------------------
12081 ! This subroutine calculates the derivatives of the consecutive virtual
12082 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12083 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12084 ! in the angles alpha and omega, describing the location of a side chain
12085 ! in its local coordinate system.
12086 !
12087 ! The derivatives are stored in the following arrays:
12088 !
12089 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12090 ! The structure is as follows:
12091 !
12092 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12093 ! 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)
12094 !         . . . . . . . . . . . .  . . . . . .
12095 ! 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)
12096 !                          .
12097 !                          .
12098 !                          .
12099 ! 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)
12100 !
12101 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12102 ! The structure is same as above.
12103 !
12104 ! DCDS - the derivatives of the side chain vectors in the local spherical
12105 ! andgles alph and omega:
12106 !
12107 ! 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)
12108 ! 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)
12109 !                          .
12110 !                          .
12111 !                          .
12112 ! 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)
12113 !
12114 ! Version of March '95, based on an early version of November '91.
12115 !
12116 !**********************************************************************
12117 !      implicit real*8 (a-h,o-z)
12118 !      include 'DIMENSIONS'
12119 !      include 'COMMON.VAR'
12120 !      include 'COMMON.CHAIN'
12121 !      include 'COMMON.DERIV'
12122 !      include 'COMMON.GEO'
12123 !      include 'COMMON.LOCAL'
12124 !      include 'COMMON.INTERACT'
12125       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12126       real(kind=8),dimension(3,3) :: dp,temp
12127 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12128       real(kind=8),dimension(3) :: xx,xx1
12129 !el local variables
12130       integer :: i,k,l,j,m,ind,ind1,jjj
12131       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12132                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12133                  sint2,xp,yp,xxp,yyp,zzp,dj
12134
12135 !      common /przechowalnia/ fromto
12136       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12137 ! get the position of the jth ijth fragment of the chain coordinate system
12138 ! in the fromto array.
12139 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12140 !
12141 !      maxdim=(nres-1)*(nres-2)/2
12142 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12143 ! calculate the derivatives of transformation matrix elements in theta
12144 !
12145
12146 !el      call flush(iout) !el
12147       do i=1,nres-2
12148         rdt(1,1,i)=-rt(1,2,i)
12149         rdt(1,2,i)= rt(1,1,i)
12150         rdt(1,3,i)= 0.0d0
12151         rdt(2,1,i)=-rt(2,2,i)
12152         rdt(2,2,i)= rt(2,1,i)
12153         rdt(2,3,i)= 0.0d0
12154         rdt(3,1,i)=-rt(3,2,i)
12155         rdt(3,2,i)= rt(3,1,i)
12156         rdt(3,3,i)= 0.0d0
12157       enddo
12158 !
12159 ! derivatives in phi
12160 !
12161       do i=2,nres-2
12162         drt(1,1,i)= 0.0d0
12163         drt(1,2,i)= 0.0d0
12164         drt(1,3,i)= 0.0d0
12165         drt(2,1,i)= rt(3,1,i)
12166         drt(2,2,i)= rt(3,2,i)
12167         drt(2,3,i)= rt(3,3,i)
12168         drt(3,1,i)=-rt(2,1,i)
12169         drt(3,2,i)=-rt(2,2,i)
12170         drt(3,3,i)=-rt(2,3,i)
12171       enddo
12172 !
12173 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12174 !
12175       do i=2,nres-2
12176         ind=indmat(i,i+1)
12177         do k=1,3
12178           do l=1,3
12179             temp(k,l)=rt(k,l,i)
12180           enddo
12181         enddo
12182         do k=1,3
12183           do l=1,3
12184             fromto(k,l,ind)=temp(k,l)
12185           enddo
12186         enddo
12187         do j=i+1,nres-2
12188           ind=indmat(i,j+1)
12189           do k=1,3
12190             do l=1,3
12191               dpkl=0.0d0
12192               do m=1,3
12193                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12194               enddo
12195               dp(k,l)=dpkl
12196               fromto(k,l,ind)=dpkl
12197             enddo
12198           enddo
12199           do k=1,3
12200             do l=1,3
12201               temp(k,l)=dp(k,l)
12202             enddo
12203           enddo
12204         enddo
12205       enddo
12206 !
12207 ! Calculate derivatives.
12208 !
12209       ind1=0
12210       do i=1,nres-2
12211       ind1=ind1+1
12212 !
12213 ! Derivatives of DC(i+1) in theta(i+2)
12214 !
12215         do j=1,3
12216           do k=1,2
12217             dpjk=0.0D0
12218             do l=1,3
12219               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12220             enddo
12221             dp(j,k)=dpjk
12222             prordt(j,k,i)=dp(j,k)
12223           enddo
12224           dp(j,3)=0.0D0
12225           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12226         enddo
12227 !
12228 ! Derivatives of SC(i+1) in theta(i+2)
12229 !
12230         xx1(1)=-0.5D0*xloc(2,i+1)
12231         xx1(2)= 0.5D0*xloc(1,i+1)
12232         do j=1,3
12233           xj=0.0D0
12234           do k=1,2
12235             xj=xj+r(j,k,i)*xx1(k)
12236           enddo
12237           xx(j)=xj
12238         enddo
12239         do j=1,3
12240           rj=0.0D0
12241           do k=1,3
12242             rj=rj+prod(j,k,i)*xx(k)
12243           enddo
12244           dxdv(j,ind1)=rj
12245         enddo
12246 !
12247 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12248 ! than the other off-diagonal derivatives.
12249 !
12250         do j=1,3
12251           dxoiij=0.0D0
12252           do k=1,3
12253             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12254           enddo
12255           dxdv(j,ind1+1)=dxoiij
12256         enddo
12257 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12258 !
12259 ! Derivatives of DC(i+1) in phi(i+2)
12260 !
12261         do j=1,3
12262           do k=1,3
12263             dpjk=0.0
12264             do l=2,3
12265               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12266             enddo
12267             dp(j,k)=dpjk
12268             prodrt(j,k,i)=dp(j,k)
12269           enddo
12270           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12271         enddo
12272 !
12273 ! Derivatives of SC(i+1) in phi(i+2)
12274 !
12275         xx(1)= 0.0D0
12276         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12277         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12278         do j=1,3
12279           rj=0.0D0
12280           do k=2,3
12281             rj=rj+prod(j,k,i)*xx(k)
12282           enddo
12283           dxdv(j+3,ind1)=-rj
12284         enddo
12285 !
12286 ! Derivatives of SC(i+1) in phi(i+3).
12287 !
12288         do j=1,3
12289           dxoiij=0.0D0
12290           do k=1,3
12291             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12292           enddo
12293           dxdv(j+3,ind1+1)=dxoiij
12294         enddo
12295 !
12296 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12297 ! theta(nres) and phi(i+3) thru phi(nres).
12298 !
12299         do j=i+1,nres-2
12300         ind1=ind1+1
12301         ind=indmat(i+1,j+1)
12302 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12303           do k=1,3
12304             do l=1,3
12305               tempkl=0.0D0
12306               do m=1,2
12307                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12308               enddo
12309               temp(k,l)=tempkl
12310             enddo
12311           enddo
12312 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12313 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12314 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12315 ! Derivatives of virtual-bond vectors in theta
12316           do k=1,3
12317             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12318           enddo
12319 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12320 ! Derivatives of SC vectors in theta
12321           do k=1,3
12322             dxoijk=0.0D0
12323             do l=1,3
12324               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12325             enddo
12326             dxdv(k,ind1+1)=dxoijk
12327           enddo
12328 !
12329 !--- Calculate the derivatives in phi
12330 !
12331           do k=1,3
12332             do l=1,3
12333               tempkl=0.0D0
12334               do m=1,3
12335                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12336               enddo
12337               temp(k,l)=tempkl
12338             enddo
12339           enddo
12340           do k=1,3
12341             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12342         enddo
12343           do k=1,3
12344             dxoijk=0.0D0
12345             do l=1,3
12346               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12347             enddo
12348             dxdv(k+3,ind1+1)=dxoijk
12349           enddo
12350         enddo
12351       enddo
12352 !
12353 ! Derivatives in alpha and omega:
12354 !
12355       do i=2,nres-1
12356 !       dsci=dsc(itype(i,1))
12357         dsci=vbld(i+nres)
12358 #ifdef OSF
12359         alphi=alph(i)
12360         omegi=omeg(i)
12361         if(alphi.ne.alphi) alphi=100.0
12362         if(omegi.ne.omegi) omegi=-100.0
12363 #else
12364       alphi=alph(i)
12365       omegi=omeg(i)
12366 #endif
12367 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12368       cosalphi=dcos(alphi)
12369       sinalphi=dsin(alphi)
12370       cosomegi=dcos(omegi)
12371       sinomegi=dsin(omegi)
12372       temp(1,1)=-dsci*sinalphi
12373       temp(2,1)= dsci*cosalphi*cosomegi
12374       temp(3,1)=-dsci*cosalphi*sinomegi
12375       temp(1,2)=0.0D0
12376       temp(2,2)=-dsci*sinalphi*sinomegi
12377       temp(3,2)=-dsci*sinalphi*cosomegi
12378       theta2=pi-0.5D0*theta(i+1)
12379       cost2=dcos(theta2)
12380       sint2=dsin(theta2)
12381       jjj=0
12382 !d      print *,((temp(l,k),l=1,3),k=1,2)
12383         do j=1,2
12384         xp=temp(1,j)
12385         yp=temp(2,j)
12386         xxp= xp*cost2+yp*sint2
12387         yyp=-xp*sint2+yp*cost2
12388         zzp=temp(3,j)
12389         xx(1)=xxp
12390         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12391         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12392         do k=1,3
12393           dj=0.0D0
12394           do l=1,3
12395             dj=dj+prod(k,l,i-1)*xx(l)
12396             enddo
12397           dxds(jjj+k,i)=dj
12398           enddo
12399         jjj=jjj+3
12400       enddo
12401       enddo
12402       return
12403       end subroutine cartder
12404 !-----------------------------------------------------------------------------
12405 ! checkder_p.F
12406 !-----------------------------------------------------------------------------
12407       subroutine check_cartgrad
12408 ! Check the gradient of Cartesian coordinates in internal coordinates.
12409 !      implicit real*8 (a-h,o-z)
12410 !      include 'DIMENSIONS'
12411 !      include 'COMMON.IOUNITS'
12412 !      include 'COMMON.VAR'
12413 !      include 'COMMON.CHAIN'
12414 !      include 'COMMON.GEO'
12415 !      include 'COMMON.LOCAL'
12416 !      include 'COMMON.DERIV'
12417       real(kind=8),dimension(6,nres) :: temp
12418       real(kind=8),dimension(3) :: xx,gg
12419       integer :: i,k,j,ii
12420       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12421 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12422 !
12423 ! Check the gradient of the virtual-bond and SC vectors in the internal
12424 ! coordinates.
12425 !
12426       aincr=1.0d-6
12427       aincr2=5.0d-7
12428       call cartder
12429       write (iout,'(a)') '**************** dx/dalpha'
12430       write (iout,'(a)')
12431       do i=2,nres-1
12432       alphi=alph(i)
12433       alph(i)=alph(i)+aincr
12434       do k=1,3
12435         temp(k,i)=dc(k,nres+i)
12436         enddo
12437       call chainbuild
12438       do k=1,3
12439         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12440         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12441         enddo
12442         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12443         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12444         write (iout,'(a)')
12445       alph(i)=alphi
12446       call chainbuild
12447       enddo
12448       write (iout,'(a)')
12449       write (iout,'(a)') '**************** dx/domega'
12450       write (iout,'(a)')
12451       do i=2,nres-1
12452       omegi=omeg(i)
12453       omeg(i)=omeg(i)+aincr
12454       do k=1,3
12455         temp(k,i)=dc(k,nres+i)
12456         enddo
12457       call chainbuild
12458       do k=1,3
12459           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12460           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12461                 (aincr*dabs(dxds(k+3,i))+aincr))
12462         enddo
12463         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12464             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12465         write (iout,'(a)')
12466       omeg(i)=omegi
12467       call chainbuild
12468       enddo
12469       write (iout,'(a)')
12470       write (iout,'(a)') '**************** dx/dtheta'
12471       write (iout,'(a)')
12472       do i=3,nres
12473       theti=theta(i)
12474         theta(i)=theta(i)+aincr
12475         do j=i-1,nres-1
12476           do k=1,3
12477             temp(k,j)=dc(k,nres+j)
12478           enddo
12479         enddo
12480         call chainbuild
12481         do j=i-1,nres-1
12482         ii = indmat(i-2,j)
12483 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12484         do k=1,3
12485           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12486           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12487                   (aincr*dabs(dxdv(k,ii))+aincr))
12488           enddo
12489           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12490               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12491           write(iout,'(a)')
12492         enddo
12493         write (iout,'(a)')
12494         theta(i)=theti
12495         call chainbuild
12496       enddo
12497       write (iout,'(a)') '***************** dx/dphi'
12498       write (iout,'(a)')
12499       do i=4,nres
12500         phi(i)=phi(i)+aincr
12501         do j=i-1,nres-1
12502           do k=1,3
12503             temp(k,j)=dc(k,nres+j)
12504           enddo
12505         enddo
12506         call chainbuild
12507         do j=i-1,nres-1
12508         ii = indmat(i-2,j)
12509 !         print *,'ii=',ii
12510         do k=1,3
12511           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12512             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12513                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12514           enddo
12515           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12516               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12517           write(iout,'(a)')
12518         enddo
12519         phi(i)=phi(i)-aincr
12520         call chainbuild
12521       enddo
12522       write (iout,'(a)') '****************** ddc/dtheta'
12523       do i=1,nres-2
12524         thet=theta(i+2)
12525         theta(i+2)=thet+aincr
12526         do j=i,nres
12527           do k=1,3
12528             temp(k,j)=dc(k,j)
12529           enddo
12530         enddo
12531         call chainbuild
12532         do j=i+1,nres-1
12533         ii = indmat(i,j)
12534 !         print *,'ii=',ii
12535         do k=1,3
12536           gg(k)=(dc(k,j)-temp(k,j))/aincr
12537           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12538                  (aincr*dabs(dcdv(k,ii))+aincr))
12539           enddo
12540           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12541                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12542         write (iout,'(a)')
12543         enddo
12544         do j=1,nres
12545           do k=1,3
12546             dc(k,j)=temp(k,j)
12547           enddo
12548         enddo
12549         theta(i+2)=thet
12550       enddo
12551       write (iout,'(a)') '******************* ddc/dphi'
12552       do i=1,nres-3
12553         phii=phi(i+3)
12554         phi(i+3)=phii+aincr
12555         do j=1,nres
12556           do k=1,3
12557             temp(k,j)=dc(k,j)
12558           enddo
12559         enddo
12560         call chainbuild
12561         do j=i+2,nres-1
12562         ii = indmat(i+1,j)
12563 !         print *,'ii=',ii
12564         do k=1,3
12565           gg(k)=(dc(k,j)-temp(k,j))/aincr
12566             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12567                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12568           enddo
12569           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12570                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12571         write (iout,'(a)')
12572         enddo
12573         do j=1,nres
12574           do k=1,3
12575             dc(k,j)=temp(k,j)
12576           enddo
12577         enddo
12578         phi(i+3)=phii
12579       enddo
12580       return
12581       end subroutine check_cartgrad
12582 !-----------------------------------------------------------------------------
12583       subroutine check_ecart
12584 ! Check the gradient of the energy in Cartesian coordinates.
12585 !     implicit real*8 (a-h,o-z)
12586 !     include 'DIMENSIONS'
12587 !     include 'COMMON.CHAIN'
12588 !     include 'COMMON.DERIV'
12589 !     include 'COMMON.IOUNITS'
12590 !     include 'COMMON.VAR'
12591 !     include 'COMMON.CONTACTS'
12592       use comm_srutu
12593 !el      integer :: icall
12594 !el      common /srutu/ icall
12595       real(kind=8),dimension(6) :: ggg
12596       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12597       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12598       real(kind=8),dimension(6,nres) :: grad_s
12599       real(kind=8),dimension(0:n_ene) :: energia,energia1
12600       integer :: uiparm(1)
12601       real(kind=8) :: urparm(1)
12602 !EL      external fdum
12603       integer :: nf,i,j,k
12604       real(kind=8) :: aincr,etot,etot1
12605       icg=1
12606       nf=0
12607       nfl=0
12608       call zerograd
12609       aincr=1.0D-5
12610       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12611       nf=0
12612       icall=0
12613       call geom_to_var(nvar,x)
12614       call etotal(energia)
12615       etot=energia(0)
12616 !el      call enerprint(energia)
12617       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12618       icall =1
12619       do i=1,nres
12620         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12621       enddo
12622       do i=1,nres
12623       do j=1,3
12624         grad_s(j,i)=gradc(j,i,icg)
12625         grad_s(j+3,i)=gradx(j,i,icg)
12626         enddo
12627       enddo
12628       call flush(iout)
12629       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12630       do i=1,nres
12631         do j=1,3
12632         xx(j)=c(j,i+nres)
12633         ddc(j)=dc(j,i)
12634         ddx(j)=dc(j,i+nres)
12635         enddo
12636       do j=1,3
12637         dc(j,i)=dc(j,i)+aincr
12638         do k=i+1,nres
12639           c(j,k)=c(j,k)+aincr
12640           c(j,k+nres)=c(j,k+nres)+aincr
12641           enddo
12642           call zerograd
12643           call etotal(energia1)
12644           etot1=energia1(0)
12645         ggg(j)=(etot1-etot)/aincr
12646         dc(j,i)=ddc(j)
12647         do k=i+1,nres
12648           c(j,k)=c(j,k)-aincr
12649           c(j,k+nres)=c(j,k+nres)-aincr
12650           enddo
12651         enddo
12652       do j=1,3
12653         c(j,i+nres)=c(j,i+nres)+aincr
12654         dc(j,i+nres)=dc(j,i+nres)+aincr
12655           call zerograd
12656           call etotal(energia1)
12657           etot1=energia1(0)
12658         ggg(j+3)=(etot1-etot)/aincr
12659         c(j,i+nres)=xx(j)
12660         dc(j,i+nres)=ddx(j)
12661         enddo
12662       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12663          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12664       enddo
12665       return
12666       end subroutine check_ecart
12667 #ifdef CARGRAD
12668 !-----------------------------------------------------------------------------
12669       subroutine check_ecartint
12670 ! Check the gradient of the energy in Cartesian coordinates.
12671       use io_base, only: intout
12672 !      implicit real*8 (a-h,o-z)
12673 !      include 'DIMENSIONS'
12674 !      include 'COMMON.CONTROL'
12675 !      include 'COMMON.CHAIN'
12676 !      include 'COMMON.DERIV'
12677 !      include 'COMMON.IOUNITS'
12678 !      include 'COMMON.VAR'
12679 !      include 'COMMON.CONTACTS'
12680 !      include 'COMMON.MD'
12681 !      include 'COMMON.LOCAL'
12682 !      include 'COMMON.SPLITELE'
12683       use comm_srutu
12684 !el      integer :: icall
12685 !el      common /srutu/ icall
12686       real(kind=8),dimension(6) :: ggg,ggg1
12687       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12688       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12689       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12690       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12691       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12692       real(kind=8),dimension(0:n_ene) :: energia,energia1
12693       integer :: uiparm(1)
12694       real(kind=8) :: urparm(1)
12695 !EL      external fdum
12696       integer :: i,j,k,nf
12697       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12698                    etot21,etot22
12699       r_cut=2.0d0
12700       rlambd=0.3d0
12701       icg=1
12702       nf=0
12703       nfl=0
12704       call intout
12705 !      call intcartderiv
12706 !      call checkintcartgrad
12707       call zerograd
12708       aincr=1.0D-5
12709       write(iout,*) 'Calling CHECK_ECARTINT.'
12710       nf=0
12711       icall=0
12712       call geom_to_var(nvar,x)
12713       write (iout,*) "split_ene ",split_ene
12714       call flush(iout)
12715       if (.not.split_ene) then
12716         call zerograd
12717         call etotal(energia)
12718         etot=energia(0)
12719         call cartgrad
12720         icall =1
12721         do i=1,nres
12722           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12723         enddo
12724         do j=1,3
12725           grad_s(j,0)=gcart(j,0)
12726         enddo
12727         do i=1,nres
12728           do j=1,3
12729             grad_s(j,i)=gcart(j,i)
12730             grad_s(j+3,i)=gxcart(j,i)
12731           enddo
12732         enddo
12733       else
12734 !- split gradient check
12735         call zerograd
12736         call etotal_long(energia)
12737 !el        call enerprint(energia)
12738         call cartgrad
12739         icall =1
12740         do i=1,nres
12741           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12742           (gxcart(j,i),j=1,3)
12743         enddo
12744         do j=1,3
12745           grad_s(j,0)=gcart(j,0)
12746         enddo
12747         do i=1,nres
12748           do j=1,3
12749             grad_s(j,i)=gcart(j,i)
12750             grad_s(j+3,i)=gxcart(j,i)
12751           enddo
12752         enddo
12753         call zerograd
12754         call etotal_short(energia)
12755         call enerprint(energia)
12756         call cartgrad
12757         icall =1
12758         do i=1,nres
12759           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12760           (gxcart(j,i),j=1,3)
12761         enddo
12762         do j=1,3
12763           grad_s1(j,0)=gcart(j,0)
12764         enddo
12765         do i=1,nres
12766           do j=1,3
12767             grad_s1(j,i)=gcart(j,i)
12768             grad_s1(j+3,i)=gxcart(j,i)
12769           enddo
12770         enddo
12771       endif
12772       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12773 !      do i=1,nres
12774       do i=nnt,nct
12775         do j=1,3
12776           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12777           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12778         ddc(j)=c(j,i)
12779         ddx(j)=c(j,i+nres)
12780           dcnorm_safe1(j)=dc_norm(j,i-1)
12781           dcnorm_safe2(j)=dc_norm(j,i)
12782           dxnorm_safe(j)=dc_norm(j,i+nres)
12783         enddo
12784       do j=1,3
12785         c(j,i)=ddc(j)+aincr
12786           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12787           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12788           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12789           dc(j,i)=c(j,i+1)-c(j,i)
12790           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12791           call int_from_cart1(.false.)
12792           if (.not.split_ene) then
12793            call zerograd
12794             call etotal(energia1)
12795             etot1=energia1(0)
12796             write (iout,*) "ij",i,j," etot1",etot1
12797           else
12798 !- split gradient
12799             call etotal_long(energia1)
12800             etot11=energia1(0)
12801             call etotal_short(energia1)
12802             etot12=energia1(0)
12803           endif
12804 !- end split gradient
12805 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12806         c(j,i)=ddc(j)-aincr
12807           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12808           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12809           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12810           dc(j,i)=c(j,i+1)-c(j,i)
12811           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12812           call int_from_cart1(.false.)
12813           if (.not.split_ene) then
12814             call zerograd
12815             call etotal(energia1)
12816             etot2=energia1(0)
12817             write (iout,*) "ij",i,j," etot2",etot2
12818           ggg(j)=(etot1-etot2)/(2*aincr)
12819           else
12820 !- split gradient
12821             call etotal_long(energia1)
12822             etot21=energia1(0)
12823           ggg(j)=(etot11-etot21)/(2*aincr)
12824             call etotal_short(energia1)
12825             etot22=energia1(0)
12826           ggg1(j)=(etot12-etot22)/(2*aincr)
12827 !- end split gradient
12828 !            write (iout,*) "etot21",etot21," etot22",etot22
12829           endif
12830 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12831         c(j,i)=ddc(j)
12832           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12833           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12834           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12835           dc(j,i)=c(j,i+1)-c(j,i)
12836           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12837           dc_norm(j,i-1)=dcnorm_safe1(j)
12838           dc_norm(j,i)=dcnorm_safe2(j)
12839           dc_norm(j,i+nres)=dxnorm_safe(j)
12840         enddo
12841       do j=1,3
12842         c(j,i+nres)=ddx(j)+aincr
12843           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12844           call int_from_cart1(.false.)
12845           if (.not.split_ene) then
12846             call zerograd
12847             call etotal(energia1)
12848             etot1=energia1(0)
12849           else
12850 !- split gradient
12851             call etotal_long(energia1)
12852             etot11=energia1(0)
12853             call etotal_short(energia1)
12854             etot12=energia1(0)
12855           endif
12856 !- end split gradient
12857         c(j,i+nres)=ddx(j)-aincr
12858           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12859           call int_from_cart1(.false.)
12860           if (.not.split_ene) then
12861            call zerograd
12862            call etotal(energia1)
12863             etot2=energia1(0)
12864           ggg(j+3)=(etot1-etot2)/(2*aincr)
12865           else
12866 !- split gradient
12867             call etotal_long(energia1)
12868             etot21=energia1(0)
12869           ggg(j+3)=(etot11-etot21)/(2*aincr)
12870             call etotal_short(energia1)
12871             etot22=energia1(0)
12872           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12873 !- end split gradient
12874           endif
12875 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12876         c(j,i+nres)=ddx(j)
12877           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12878           dc_norm(j,i+nres)=dxnorm_safe(j)
12879           call int_from_cart1(.false.)
12880         enddo
12881       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12882          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12883         if (split_ene) then
12884           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12885          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12886          k=1,6)
12887          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12888          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12889          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12890         endif
12891       enddo
12892       return
12893       end subroutine check_ecartint
12894 #else
12895 !-----------------------------------------------------------------------------
12896       subroutine check_ecartint
12897 ! Check the gradient of the energy in Cartesian coordinates.
12898       use io_base, only: intout
12899 !      implicit real*8 (a-h,o-z)
12900 !      include 'DIMENSIONS'
12901 !      include 'COMMON.CONTROL'
12902 !      include 'COMMON.CHAIN'
12903 !      include 'COMMON.DERIV'
12904 !      include 'COMMON.IOUNITS'
12905 !      include 'COMMON.VAR'
12906 !      include 'COMMON.CONTACTS'
12907 !      include 'COMMON.MD'
12908 !      include 'COMMON.LOCAL'
12909 !      include 'COMMON.SPLITELE'
12910       use comm_srutu
12911 !el      integer :: icall
12912 !el      common /srutu/ icall
12913       real(kind=8),dimension(6) :: ggg,ggg1
12914       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12915       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12916       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12917       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12918       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12919       real(kind=8),dimension(0:n_ene) :: energia,energia1
12920       integer :: uiparm(1)
12921       real(kind=8) :: urparm(1)
12922 !EL      external fdum
12923       integer :: i,j,k,nf
12924       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12925                    etot21,etot22
12926       r_cut=2.0d0
12927       rlambd=0.3d0
12928       icg=1
12929       nf=0
12930       nfl=0
12931       call intout
12932 !      call intcartderiv
12933 !      call checkintcartgrad
12934       call zerograd
12935       aincr=1.0D-6
12936       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12937       nf=0
12938       icall=0
12939       call geom_to_var(nvar,x)
12940       if (.not.split_ene) then
12941         call etotal(energia)
12942         etot=energia(0)
12943 !el        call enerprint(energia)
12944         call cartgrad
12945         icall =1
12946         do i=1,nres
12947           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12948         enddo
12949         do j=1,3
12950           grad_s(j,0)=gcart(j,0)
12951         enddo
12952         do i=1,nres
12953           do j=1,3
12954             grad_s(j,i)=gcart(j,i)
12955 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12956
12957 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12958             grad_s(j+3,i)=gxcart(j,i)
12959           enddo
12960         enddo
12961       else
12962 !- split gradient check
12963         call zerograd
12964         call etotal_long(energia)
12965 !el        call enerprint(energia)
12966         call cartgrad
12967         icall =1
12968         do i=1,nres
12969           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12970           (gxcart(j,i),j=1,3)
12971         enddo
12972         do j=1,3
12973           grad_s(j,0)=gcart(j,0)
12974         enddo
12975         do i=1,nres
12976           do j=1,3
12977             grad_s(j,i)=gcart(j,i)
12978 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12979             grad_s(j+3,i)=gxcart(j,i)
12980           enddo
12981         enddo
12982         call zerograd
12983         call etotal_short(energia)
12984 !el        call enerprint(energia)
12985         call cartgrad
12986         icall =1
12987         do i=1,nres
12988           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12989           (gxcart(j,i),j=1,3)
12990         enddo
12991         do j=1,3
12992           grad_s1(j,0)=gcart(j,0)
12993         enddo
12994         do i=1,nres
12995           do j=1,3
12996             grad_s1(j,i)=gcart(j,i)
12997             grad_s1(j+3,i)=gxcart(j,i)
12998           enddo
12999         enddo
13000       endif
13001       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13002       do i=0,nres
13003         do j=1,3
13004         xx(j)=c(j,i+nres)
13005         ddc(j)=dc(j,i)
13006         ddx(j)=dc(j,i+nres)
13007           do k=1,3
13008             dcnorm_safe(k)=dc_norm(k,i)
13009             dxnorm_safe(k)=dc_norm(k,i+nres)
13010           enddo
13011         enddo
13012       do j=1,3
13013         dc(j,i)=ddc(j)+aincr
13014           call chainbuild_cart
13015 #ifdef MPI
13016 ! Broadcast the order to compute internal coordinates to the slaves.
13017 !          if (nfgtasks.gt.1)
13018 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13019 #endif
13020 !          call int_from_cart1(.false.)
13021           if (.not.split_ene) then
13022            call zerograd
13023             call etotal(energia1)
13024             etot1=energia1(0)
13025 !            call enerprint(energia1)
13026           else
13027 !- split gradient
13028             call etotal_long(energia1)
13029             etot11=energia1(0)
13030             call etotal_short(energia1)
13031             etot12=energia1(0)
13032 !            write (iout,*) "etot11",etot11," etot12",etot12
13033           endif
13034 !- end split gradient
13035 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13036         dc(j,i)=ddc(j)-aincr
13037           call chainbuild_cart
13038 !          call int_from_cart1(.false.)
13039           if (.not.split_ene) then
13040                   call zerograd
13041             call etotal(energia1)
13042             etot2=energia1(0)
13043           ggg(j)=(etot1-etot2)/(2*aincr)
13044           else
13045 !- split gradient
13046             call etotal_long(energia1)
13047             etot21=energia1(0)
13048           ggg(j)=(etot11-etot21)/(2*aincr)
13049             call etotal_short(energia1)
13050             etot22=energia1(0)
13051           ggg1(j)=(etot12-etot22)/(2*aincr)
13052 !- end split gradient
13053 !            write (iout,*) "etot21",etot21," etot22",etot22
13054           endif
13055 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13056         dc(j,i)=ddc(j)
13057           call chainbuild_cart
13058         enddo
13059       do j=1,3
13060         dc(j,i+nres)=ddx(j)+aincr
13061           call chainbuild_cart
13062 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13063 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13064 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13065 !          write (iout,*) "dxnormnorm",dsqrt(
13066 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13067 !          write (iout,*) "dxnormnormsafe",dsqrt(
13068 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13069 !          write (iout,*)
13070           if (.not.split_ene) then
13071             call zerograd
13072             call etotal(energia1)
13073             etot1=energia1(0)
13074           else
13075 !- split gradient
13076             call etotal_long(energia1)
13077             etot11=energia1(0)
13078             call etotal_short(energia1)
13079             etot12=energia1(0)
13080           endif
13081 !- end split gradient
13082 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13083         dc(j,i+nres)=ddx(j)-aincr
13084           call chainbuild_cart
13085 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13086 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13087 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13088 !          write (iout,*)
13089 !          write (iout,*) "dxnormnorm",dsqrt(
13090 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13091 !          write (iout,*) "dxnormnormsafe",dsqrt(
13092 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13093           if (.not.split_ene) then
13094             call zerograd
13095             call etotal(energia1)
13096             etot2=energia1(0)
13097           ggg(j+3)=(etot1-etot2)/(2*aincr)
13098           else
13099 !- split gradient
13100             call etotal_long(energia1)
13101             etot21=energia1(0)
13102           ggg(j+3)=(etot11-etot21)/(2*aincr)
13103             call etotal_short(energia1)
13104             etot22=energia1(0)
13105           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13106 !- end split gradient
13107           endif
13108 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13109         dc(j,i+nres)=ddx(j)
13110           call chainbuild_cart
13111         enddo
13112       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13113          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13114         if (split_ene) then
13115           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13116          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13117          k=1,6)
13118          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13119          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13120          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13121         endif
13122       enddo
13123       return
13124       end subroutine check_ecartint
13125 #endif
13126 !-----------------------------------------------------------------------------
13127       subroutine check_eint
13128 ! Check the gradient of energy in internal coordinates.
13129 !      implicit real*8 (a-h,o-z)
13130 !      include 'DIMENSIONS'
13131 !      include 'COMMON.CHAIN'
13132 !      include 'COMMON.DERIV'
13133 !      include 'COMMON.IOUNITS'
13134 !      include 'COMMON.VAR'
13135 !      include 'COMMON.GEO'
13136       use comm_srutu
13137 !el      integer :: icall
13138 !el      common /srutu/ icall
13139       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13140       integer :: uiparm(1)
13141       real(kind=8) :: urparm(1)
13142       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13143       character(len=6) :: key
13144 !EL      external fdum
13145       integer :: i,ii,nf
13146       real(kind=8) :: xi,aincr,etot,etot1,etot2
13147       call zerograd
13148       aincr=1.0D-7
13149       print '(a)','Calling CHECK_INT.'
13150       nf=0
13151       nfl=0
13152       icg=1
13153       call geom_to_var(nvar,x)
13154       call var_to_geom(nvar,x)
13155       call chainbuild
13156       icall=1
13157 !      print *,'ICG=',ICG
13158       call etotal(energia)
13159       etot = energia(0)
13160 !el      call enerprint(energia)
13161 !      print *,'ICG=',ICG
13162 #ifdef MPL
13163       if (MyID.ne.BossID) then
13164         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13165         nf=x(nvar+1)
13166         nfl=x(nvar+2)
13167         icg=x(nvar+3)
13168       endif
13169 #endif
13170       nf=1
13171       nfl=3
13172 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13173       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13174 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13175       icall=1
13176       do i=1,nvar
13177         xi=x(i)
13178         x(i)=xi-0.5D0*aincr
13179         call var_to_geom(nvar,x)
13180         call chainbuild
13181         call etotal(energia1)
13182         etot1=energia1(0)
13183         x(i)=xi+0.5D0*aincr
13184         call var_to_geom(nvar,x)
13185         call chainbuild
13186         call etotal(energia2)
13187         etot2=energia2(0)
13188         gg(i)=(etot2-etot1)/aincr
13189         write (iout,*) i,etot1,etot2
13190         x(i)=xi
13191       enddo
13192       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13193           '     RelDiff*100% '
13194       do i=1,nvar
13195         if (i.le.nphi) then
13196           ii=i
13197           key = ' phi'
13198         else if (i.le.nphi+ntheta) then
13199           ii=i-nphi
13200           key=' theta'
13201         else if (i.le.nphi+ntheta+nside) then
13202            ii=i-(nphi+ntheta)
13203            key=' alpha'
13204         else
13205            ii=i-(nphi+ntheta+nside)
13206            key=' omega'
13207         endif
13208         write (iout,'(i3,a,i3,3(1pd16.6))') &
13209        i,key,ii,gg(i),gana(i),&
13210        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13211       enddo
13212       return
13213       end subroutine check_eint
13214 !-----------------------------------------------------------------------------
13215 ! econstr_local.F
13216 !-----------------------------------------------------------------------------
13217       subroutine Econstr_back
13218 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13219 !      implicit real*8 (a-h,o-z)
13220 !      include 'DIMENSIONS'
13221 !      include 'COMMON.CONTROL'
13222 !      include 'COMMON.VAR'
13223 !      include 'COMMON.MD'
13224       use MD_data
13225 !#ifndef LANG0
13226 !      include 'COMMON.LANGEVIN'
13227 !#else
13228 !      include 'COMMON.LANGEVIN.lang0'
13229 !#endif
13230 !      include 'COMMON.CHAIN'
13231 !      include 'COMMON.DERIV'
13232 !      include 'COMMON.GEO'
13233 !      include 'COMMON.LOCAL'
13234 !      include 'COMMON.INTERACT'
13235 !      include 'COMMON.IOUNITS'
13236 !      include 'COMMON.NAMES'
13237 !      include 'COMMON.TIME1'
13238       integer :: i,j,ii,k
13239       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13240
13241       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13242       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13243       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13244
13245       Uconst_back=0.0d0
13246       do i=1,nres
13247         dutheta(i)=0.0d0
13248         dugamma(i)=0.0d0
13249         do j=1,3
13250           duscdiff(j,i)=0.0d0
13251           duscdiffx(j,i)=0.0d0
13252         enddo
13253       enddo
13254       do i=1,nfrag_back
13255         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13256 !
13257 ! Deviations from theta angles
13258 !
13259         utheta_i=0.0d0
13260         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13261           dtheta_i=theta(j)-thetaref(j)
13262           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13263           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13264         enddo
13265         utheta(i)=utheta_i/(ii-1)
13266 !
13267 ! Deviations from gamma angles
13268 !
13269         ugamma_i=0.0d0
13270         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13271           dgamma_i=pinorm(phi(j)-phiref(j))
13272 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13273           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13274           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13275 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13276         enddo
13277         ugamma(i)=ugamma_i/(ii-2)
13278 !
13279 ! Deviations from local SC geometry
13280 !
13281         uscdiff(i)=0.0d0
13282         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13283           dxx=xxtab(j)-xxref(j)
13284           dyy=yytab(j)-yyref(j)
13285           dzz=zztab(j)-zzref(j)
13286           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13287           do k=1,3
13288             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13289              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13290              (ii-1)
13291             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13292              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13293              (ii-1)
13294             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13295            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13296             /(ii-1)
13297           enddo
13298 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13299 !     &      xxref(j),yyref(j),zzref(j)
13300         enddo
13301         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13302 !        write (iout,*) i," uscdiff",uscdiff(i)
13303 !
13304 ! Put together deviations from local geometry
13305 !
13306         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13307           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13308 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13309 !     &   " uconst_back",uconst_back
13310         utheta(i)=dsqrt(utheta(i))
13311         ugamma(i)=dsqrt(ugamma(i))
13312         uscdiff(i)=dsqrt(uscdiff(i))
13313       enddo
13314       return
13315       end subroutine Econstr_back
13316 !-----------------------------------------------------------------------------
13317 ! energy_p_new-sep_barrier.F
13318 !-----------------------------------------------------------------------------
13319       real(kind=8) function sscale(r)
13320 !      include "COMMON.SPLITELE"
13321       real(kind=8) :: r,gamm
13322       if(r.lt.r_cut-rlamb) then
13323         sscale=1.0d0
13324       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13325         gamm=(r-(r_cut-rlamb))/rlamb
13326         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13327       else
13328         sscale=0d0
13329       endif
13330       return
13331       end function sscale
13332       real(kind=8) function sscale_grad(r)
13333 !      include "COMMON.SPLITELE"
13334       real(kind=8) :: r,gamm
13335       if(r.lt.r_cut-rlamb) then
13336         sscale_grad=0.0d0
13337       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13338         gamm=(r-(r_cut-rlamb))/rlamb
13339         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13340       else
13341         sscale_grad=0d0
13342       endif
13343       return
13344       end function sscale_grad
13345
13346 !!!!!!!!!! PBCSCALE
13347       real(kind=8) function sscale_ele(r)
13348 !      include "COMMON.SPLITELE"
13349       real(kind=8) :: r,gamm
13350       if(r.lt.r_cut_ele-rlamb_ele) then
13351         sscale_ele=1.0d0
13352       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13353         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13354         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13355       else
13356         sscale_ele=0d0
13357       endif
13358       return
13359       end function sscale_ele
13360
13361       real(kind=8)  function sscagrad_ele(r)
13362       real(kind=8) :: r,gamm
13363 !      include "COMMON.SPLITELE"
13364       if(r.lt.r_cut_ele-rlamb_ele) then
13365         sscagrad_ele=0.0d0
13366       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13367         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13368         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13369       else
13370         sscagrad_ele=0.0d0
13371       endif
13372       return
13373       end function sscagrad_ele
13374       real(kind=8) function sscalelip(r)
13375       real(kind=8) r,gamm
13376         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13377       return
13378       end function sscalelip
13379 !C-----------------------------------------------------------------------
13380       real(kind=8) function sscagradlip(r)
13381       real(kind=8) r,gamm
13382         sscagradlip=r*(6.0d0*r-6.0d0)
13383       return
13384       end function sscagradlip
13385
13386 !!!!!!!!!!!!!!!
13387 !-----------------------------------------------------------------------------
13388       subroutine elj_long(evdw)
13389 !
13390 ! This subroutine calculates the interaction energy of nonbonded side chains
13391 ! assuming the LJ potential of interaction.
13392 !
13393 !      implicit real*8 (a-h,o-z)
13394 !      include 'DIMENSIONS'
13395 !      include 'COMMON.GEO'
13396 !      include 'COMMON.VAR'
13397 !      include 'COMMON.LOCAL'
13398 !      include 'COMMON.CHAIN'
13399 !      include 'COMMON.DERIV'
13400 !      include 'COMMON.INTERACT'
13401 !      include 'COMMON.TORSION'
13402 !      include 'COMMON.SBRIDGE'
13403 !      include 'COMMON.NAMES'
13404 !      include 'COMMON.IOUNITS'
13405 !      include 'COMMON.CONTACTS'
13406       real(kind=8),parameter :: accur=1.0d-10
13407       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13408 !el local variables
13409       integer :: i,iint,j,k,itypi,itypi1,itypj
13410       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13411       real(kind=8) :: e1,e2,evdwij,evdw
13412 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13413       evdw=0.0D0
13414       do i=iatsc_s,iatsc_e
13415         itypi=itype(i,1)
13416         if (itypi.eq.ntyp1) cycle
13417         itypi1=itype(i+1,1)
13418         xi=c(1,nres+i)
13419         yi=c(2,nres+i)
13420         zi=c(3,nres+i)
13421 !
13422 ! Calculate SC interaction energy.
13423 !
13424         do iint=1,nint_gr(i)
13425 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13426 !d   &                  'iend=',iend(i,iint)
13427           do j=istart(i,iint),iend(i,iint)
13428             itypj=itype(j,1)
13429             if (itypj.eq.ntyp1) cycle
13430             xj=c(1,nres+j)-xi
13431             yj=c(2,nres+j)-yi
13432             zj=c(3,nres+j)-zi
13433             rij=xj*xj+yj*yj+zj*zj
13434             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13435             if (sss.lt.1.0d0) then
13436               rrij=1.0D0/rij
13437               eps0ij=eps(itypi,itypj)
13438               fac=rrij**expon2
13439               e1=fac*fac*aa_aq(itypi,itypj)
13440               e2=fac*bb_aq(itypi,itypj)
13441               evdwij=e1+e2
13442               evdw=evdw+(1.0d0-sss)*evdwij
13443 !
13444 ! Calculate the components of the gradient in DC and X
13445 !
13446               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13447               gg(1)=xj*fac
13448               gg(2)=yj*fac
13449               gg(3)=zj*fac
13450               do k=1,3
13451                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13452                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13453                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13454                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13455               enddo
13456             endif
13457           enddo      ! j
13458         enddo        ! iint
13459       enddo          ! i
13460       do i=1,nct
13461         do j=1,3
13462           gvdwc(j,i)=expon*gvdwc(j,i)
13463           gvdwx(j,i)=expon*gvdwx(j,i)
13464         enddo
13465       enddo
13466 !******************************************************************************
13467 !
13468 !                              N O T E !!!
13469 !
13470 ! To save time, the factor of EXPON has been extracted from ALL components
13471 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13472 ! use!
13473 !
13474 !******************************************************************************
13475       return
13476       end subroutine elj_long
13477 !-----------------------------------------------------------------------------
13478       subroutine elj_short(evdw)
13479 !
13480 ! This subroutine calculates the interaction energy of nonbonded side chains
13481 ! assuming the LJ potential of interaction.
13482 !
13483 !      implicit real*8 (a-h,o-z)
13484 !      include 'DIMENSIONS'
13485 !      include 'COMMON.GEO'
13486 !      include 'COMMON.VAR'
13487 !      include 'COMMON.LOCAL'
13488 !      include 'COMMON.CHAIN'
13489 !      include 'COMMON.DERIV'
13490 !      include 'COMMON.INTERACT'
13491 !      include 'COMMON.TORSION'
13492 !      include 'COMMON.SBRIDGE'
13493 !      include 'COMMON.NAMES'
13494 !      include 'COMMON.IOUNITS'
13495 !      include 'COMMON.CONTACTS'
13496       real(kind=8),parameter :: accur=1.0d-10
13497       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13498 !el local variables
13499       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13500       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13501       real(kind=8) :: e1,e2,evdwij,evdw
13502 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13503       evdw=0.0D0
13504       do i=iatsc_s,iatsc_e
13505         itypi=itype(i,1)
13506         if (itypi.eq.ntyp1) cycle
13507         itypi1=itype(i+1,1)
13508         xi=c(1,nres+i)
13509         yi=c(2,nres+i)
13510         zi=c(3,nres+i)
13511 ! Change 12/1/95
13512         num_conti=0
13513 !
13514 ! Calculate SC interaction energy.
13515 !
13516         do iint=1,nint_gr(i)
13517 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13518 !d   &                  'iend=',iend(i,iint)
13519           do j=istart(i,iint),iend(i,iint)
13520             itypj=itype(j,1)
13521             if (itypj.eq.ntyp1) cycle
13522             xj=c(1,nres+j)-xi
13523             yj=c(2,nres+j)-yi
13524             zj=c(3,nres+j)-zi
13525 ! Change 12/1/95 to calculate four-body interactions
13526             rij=xj*xj+yj*yj+zj*zj
13527             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13528             if (sss.gt.0.0d0) then
13529               rrij=1.0D0/rij
13530               eps0ij=eps(itypi,itypj)
13531               fac=rrij**expon2
13532               e1=fac*fac*aa_aq(itypi,itypj)
13533               e2=fac*bb_aq(itypi,itypj)
13534               evdwij=e1+e2
13535               evdw=evdw+sss*evdwij
13536 !
13537 ! Calculate the components of the gradient in DC and X
13538 !
13539               fac=-rrij*(e1+evdwij)*sss
13540               gg(1)=xj*fac
13541               gg(2)=yj*fac
13542               gg(3)=zj*fac
13543               do k=1,3
13544                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13545                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13546                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13547                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13548               enddo
13549             endif
13550           enddo      ! j
13551         enddo        ! iint
13552       enddo          ! i
13553       do i=1,nct
13554         do j=1,3
13555           gvdwc(j,i)=expon*gvdwc(j,i)
13556           gvdwx(j,i)=expon*gvdwx(j,i)
13557         enddo
13558       enddo
13559 !******************************************************************************
13560 !
13561 !                              N O T E !!!
13562 !
13563 ! To save time, the factor of EXPON has been extracted from ALL components
13564 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13565 ! use!
13566 !
13567 !******************************************************************************
13568       return
13569       end subroutine elj_short
13570 !-----------------------------------------------------------------------------
13571       subroutine eljk_long(evdw)
13572 !
13573 ! This subroutine calculates the interaction energy of nonbonded side chains
13574 ! assuming the LJK potential of interaction.
13575 !
13576 !      implicit real*8 (a-h,o-z)
13577 !      include 'DIMENSIONS'
13578 !      include 'COMMON.GEO'
13579 !      include 'COMMON.VAR'
13580 !      include 'COMMON.LOCAL'
13581 !      include 'COMMON.CHAIN'
13582 !      include 'COMMON.DERIV'
13583 !      include 'COMMON.INTERACT'
13584 !      include 'COMMON.IOUNITS'
13585 !      include 'COMMON.NAMES'
13586       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13587       logical :: scheck
13588 !el local variables
13589       integer :: i,iint,j,k,itypi,itypi1,itypj
13590       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13591                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13592 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13593       evdw=0.0D0
13594       do i=iatsc_s,iatsc_e
13595         itypi=itype(i,1)
13596         if (itypi.eq.ntyp1) cycle
13597         itypi1=itype(i+1,1)
13598         xi=c(1,nres+i)
13599         yi=c(2,nres+i)
13600         zi=c(3,nres+i)
13601 !
13602 ! Calculate SC interaction energy.
13603 !
13604         do iint=1,nint_gr(i)
13605           do j=istart(i,iint),iend(i,iint)
13606             itypj=itype(j,1)
13607             if (itypj.eq.ntyp1) cycle
13608             xj=c(1,nres+j)-xi
13609             yj=c(2,nres+j)-yi
13610             zj=c(3,nres+j)-zi
13611             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13612             fac_augm=rrij**expon
13613             e_augm=augm(itypi,itypj)*fac_augm
13614             r_inv_ij=dsqrt(rrij)
13615             rij=1.0D0/r_inv_ij
13616             sss=sscale(rij/sigma(itypi,itypj))
13617             if (sss.lt.1.0d0) then
13618               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13619               fac=r_shift_inv**expon
13620               e1=fac*fac*aa_aq(itypi,itypj)
13621               e2=fac*bb_aq(itypi,itypj)
13622               evdwij=e_augm+e1+e2
13623 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13624 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13625 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13626 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13627 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13628 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13629 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13630               evdw=evdw+(1.0d0-sss)*evdwij
13631 !
13632 ! Calculate the components of the gradient in DC and X
13633 !
13634               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13635               fac=fac*(1.0d0-sss)
13636               gg(1)=xj*fac
13637               gg(2)=yj*fac
13638               gg(3)=zj*fac
13639               do k=1,3
13640                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13641                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13642                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13643                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13644               enddo
13645             endif
13646           enddo      ! j
13647         enddo        ! iint
13648       enddo          ! i
13649       do i=1,nct
13650         do j=1,3
13651           gvdwc(j,i)=expon*gvdwc(j,i)
13652           gvdwx(j,i)=expon*gvdwx(j,i)
13653         enddo
13654       enddo
13655       return
13656       end subroutine eljk_long
13657 !-----------------------------------------------------------------------------
13658       subroutine eljk_short(evdw)
13659 !
13660 ! This subroutine calculates the interaction energy of nonbonded side chains
13661 ! assuming the LJK potential of interaction.
13662 !
13663 !      implicit real*8 (a-h,o-z)
13664 !      include 'DIMENSIONS'
13665 !      include 'COMMON.GEO'
13666 !      include 'COMMON.VAR'
13667 !      include 'COMMON.LOCAL'
13668 !      include 'COMMON.CHAIN'
13669 !      include 'COMMON.DERIV'
13670 !      include 'COMMON.INTERACT'
13671 !      include 'COMMON.IOUNITS'
13672 !      include 'COMMON.NAMES'
13673       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13674       logical :: scheck
13675 !el local variables
13676       integer :: i,iint,j,k,itypi,itypi1,itypj
13677       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13678                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13679 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13680       evdw=0.0D0
13681       do i=iatsc_s,iatsc_e
13682         itypi=itype(i,1)
13683         if (itypi.eq.ntyp1) cycle
13684         itypi1=itype(i+1,1)
13685         xi=c(1,nres+i)
13686         yi=c(2,nres+i)
13687         zi=c(3,nres+i)
13688 !
13689 ! Calculate SC interaction energy.
13690 !
13691         do iint=1,nint_gr(i)
13692           do j=istart(i,iint),iend(i,iint)
13693             itypj=itype(j,1)
13694             if (itypj.eq.ntyp1) cycle
13695             xj=c(1,nres+j)-xi
13696             yj=c(2,nres+j)-yi
13697             zj=c(3,nres+j)-zi
13698             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13699             fac_augm=rrij**expon
13700             e_augm=augm(itypi,itypj)*fac_augm
13701             r_inv_ij=dsqrt(rrij)
13702             rij=1.0D0/r_inv_ij
13703             sss=sscale(rij/sigma(itypi,itypj))
13704             if (sss.gt.0.0d0) then
13705               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13706               fac=r_shift_inv**expon
13707               e1=fac*fac*aa_aq(itypi,itypj)
13708               e2=fac*bb_aq(itypi,itypj)
13709               evdwij=e_augm+e1+e2
13710 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13711 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13712 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13713 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13714 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13715 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13716 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13717               evdw=evdw+sss*evdwij
13718 !
13719 ! Calculate the components of the gradient in DC and X
13720 !
13721               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13722               fac=fac*sss
13723               gg(1)=xj*fac
13724               gg(2)=yj*fac
13725               gg(3)=zj*fac
13726               do k=1,3
13727                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13728                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13729                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13730                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13731               enddo
13732             endif
13733           enddo      ! j
13734         enddo        ! iint
13735       enddo          ! i
13736       do i=1,nct
13737         do j=1,3
13738           gvdwc(j,i)=expon*gvdwc(j,i)
13739           gvdwx(j,i)=expon*gvdwx(j,i)
13740         enddo
13741       enddo
13742       return
13743       end subroutine eljk_short
13744 !-----------------------------------------------------------------------------
13745       subroutine ebp_long(evdw)
13746 !
13747 ! This subroutine calculates the interaction energy of nonbonded side chains
13748 ! assuming the Berne-Pechukas potential of interaction.
13749 !
13750       use calc_data
13751 !      implicit real*8 (a-h,o-z)
13752 !      include 'DIMENSIONS'
13753 !      include 'COMMON.GEO'
13754 !      include 'COMMON.VAR'
13755 !      include 'COMMON.LOCAL'
13756 !      include 'COMMON.CHAIN'
13757 !      include 'COMMON.DERIV'
13758 !      include 'COMMON.NAMES'
13759 !      include 'COMMON.INTERACT'
13760 !      include 'COMMON.IOUNITS'
13761 !      include 'COMMON.CALC'
13762       use comm_srutu
13763 !el      integer :: icall
13764 !el      common /srutu/ icall
13765 !     double precision rrsave(maxdim)
13766       logical :: lprn
13767 !el local variables
13768       integer :: iint,itypi,itypi1,itypj
13769       real(kind=8) :: rrij,xi,yi,zi,fac
13770       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13771       evdw=0.0D0
13772 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13773       evdw=0.0D0
13774 !     if (icall.eq.0) then
13775 !       lprn=.true.
13776 !     else
13777         lprn=.false.
13778 !     endif
13779 !el      ind=0
13780       do i=iatsc_s,iatsc_e
13781         itypi=itype(i,1)
13782         if (itypi.eq.ntyp1) cycle
13783         itypi1=itype(i+1,1)
13784         xi=c(1,nres+i)
13785         yi=c(2,nres+i)
13786         zi=c(3,nres+i)
13787         dxi=dc_norm(1,nres+i)
13788         dyi=dc_norm(2,nres+i)
13789         dzi=dc_norm(3,nres+i)
13790 !        dsci_inv=dsc_inv(itypi)
13791         dsci_inv=vbld_inv(i+nres)
13792 !
13793 ! Calculate SC interaction energy.
13794 !
13795         do iint=1,nint_gr(i)
13796           do j=istart(i,iint),iend(i,iint)
13797 !el            ind=ind+1
13798             itypj=itype(j,1)
13799             if (itypj.eq.ntyp1) cycle
13800 !            dscj_inv=dsc_inv(itypj)
13801             dscj_inv=vbld_inv(j+nres)
13802             chi1=chi(itypi,itypj)
13803             chi2=chi(itypj,itypi)
13804             chi12=chi1*chi2
13805             chip1=chip(itypi)
13806             chip2=chip(itypj)
13807             chip12=chip1*chip2
13808             alf1=alp(itypi)
13809             alf2=alp(itypj)
13810             alf12=0.5D0*(alf1+alf2)
13811             xj=c(1,nres+j)-xi
13812             yj=c(2,nres+j)-yi
13813             zj=c(3,nres+j)-zi
13814             dxj=dc_norm(1,nres+j)
13815             dyj=dc_norm(2,nres+j)
13816             dzj=dc_norm(3,nres+j)
13817             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13818             rij=dsqrt(rrij)
13819             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13820
13821             if (sss.lt.1.0d0) then
13822
13823 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13824               call sc_angular
13825 ! Calculate whole angle-dependent part of epsilon and contributions
13826 ! to its derivatives
13827               fac=(rrij*sigsq)**expon2
13828               e1=fac*fac*aa_aq(itypi,itypj)
13829               e2=fac*bb_aq(itypi,itypj)
13830               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13831               eps2der=evdwij*eps3rt
13832               eps3der=evdwij*eps2rt
13833               evdwij=evdwij*eps2rt*eps3rt
13834               evdw=evdw+evdwij*(1.0d0-sss)
13835               if (lprn) then
13836               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13837               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13838 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13839 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13840 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13841 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13842 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13843 !d     &          evdwij
13844               endif
13845 ! Calculate gradient components.
13846               e1=e1*eps1*eps2rt**2*eps3rt**2
13847               fac=-expon*(e1+evdwij)
13848               sigder=fac/sigsq
13849               fac=rrij*fac
13850 ! Calculate radial part of the gradient
13851               gg(1)=xj*fac
13852               gg(2)=yj*fac
13853               gg(3)=zj*fac
13854 ! Calculate the angular part of the gradient and sum add the contributions
13855 ! to the appropriate components of the Cartesian gradient.
13856               call sc_grad_scale(1.0d0-sss)
13857             endif
13858           enddo      ! j
13859         enddo        ! iint
13860       enddo          ! i
13861 !     stop
13862       return
13863       end subroutine ebp_long
13864 !-----------------------------------------------------------------------------
13865       subroutine ebp_short(evdw)
13866 !
13867 ! This subroutine calculates the interaction energy of nonbonded side chains
13868 ! assuming the Berne-Pechukas potential of interaction.
13869 !
13870       use calc_data
13871 !      implicit real*8 (a-h,o-z)
13872 !      include 'DIMENSIONS'
13873 !      include 'COMMON.GEO'
13874 !      include 'COMMON.VAR'
13875 !      include 'COMMON.LOCAL'
13876 !      include 'COMMON.CHAIN'
13877 !      include 'COMMON.DERIV'
13878 !      include 'COMMON.NAMES'
13879 !      include 'COMMON.INTERACT'
13880 !      include 'COMMON.IOUNITS'
13881 !      include 'COMMON.CALC'
13882       use comm_srutu
13883 !el      integer :: icall
13884 !el      common /srutu/ icall
13885 !     double precision rrsave(maxdim)
13886       logical :: lprn
13887 !el local variables
13888       integer :: iint,itypi,itypi1,itypj
13889       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13890       real(kind=8) :: sss,e1,e2,evdw
13891       evdw=0.0D0
13892 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13893       evdw=0.0D0
13894 !     if (icall.eq.0) then
13895 !       lprn=.true.
13896 !     else
13897         lprn=.false.
13898 !     endif
13899 !el      ind=0
13900       do i=iatsc_s,iatsc_e
13901         itypi=itype(i,1)
13902         if (itypi.eq.ntyp1) cycle
13903         itypi1=itype(i+1,1)
13904         xi=c(1,nres+i)
13905         yi=c(2,nres+i)
13906         zi=c(3,nres+i)
13907         dxi=dc_norm(1,nres+i)
13908         dyi=dc_norm(2,nres+i)
13909         dzi=dc_norm(3,nres+i)
13910 !        dsci_inv=dsc_inv(itypi)
13911         dsci_inv=vbld_inv(i+nres)
13912 !
13913 ! Calculate SC interaction energy.
13914 !
13915         do iint=1,nint_gr(i)
13916           do j=istart(i,iint),iend(i,iint)
13917 !el            ind=ind+1
13918             itypj=itype(j,1)
13919             if (itypj.eq.ntyp1) cycle
13920 !            dscj_inv=dsc_inv(itypj)
13921             dscj_inv=vbld_inv(j+nres)
13922             chi1=chi(itypi,itypj)
13923             chi2=chi(itypj,itypi)
13924             chi12=chi1*chi2
13925             chip1=chip(itypi)
13926             chip2=chip(itypj)
13927             chip12=chip1*chip2
13928             alf1=alp(itypi)
13929             alf2=alp(itypj)
13930             alf12=0.5D0*(alf1+alf2)
13931             xj=c(1,nres+j)-xi
13932             yj=c(2,nres+j)-yi
13933             zj=c(3,nres+j)-zi
13934             dxj=dc_norm(1,nres+j)
13935             dyj=dc_norm(2,nres+j)
13936             dzj=dc_norm(3,nres+j)
13937             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13938             rij=dsqrt(rrij)
13939             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13940
13941             if (sss.gt.0.0d0) then
13942
13943 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13944               call sc_angular
13945 ! Calculate whole angle-dependent part of epsilon and contributions
13946 ! to its derivatives
13947               fac=(rrij*sigsq)**expon2
13948               e1=fac*fac*aa_aq(itypi,itypj)
13949               e2=fac*bb_aq(itypi,itypj)
13950               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13951               eps2der=evdwij*eps3rt
13952               eps3der=evdwij*eps2rt
13953               evdwij=evdwij*eps2rt*eps3rt
13954               evdw=evdw+evdwij*sss
13955               if (lprn) then
13956               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13957               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13958 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13959 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13960 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13961 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13962 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13963 !d     &          evdwij
13964               endif
13965 ! Calculate gradient components.
13966               e1=e1*eps1*eps2rt**2*eps3rt**2
13967               fac=-expon*(e1+evdwij)
13968               sigder=fac/sigsq
13969               fac=rrij*fac
13970 ! Calculate radial part of the gradient
13971               gg(1)=xj*fac
13972               gg(2)=yj*fac
13973               gg(3)=zj*fac
13974 ! Calculate the angular part of the gradient and sum add the contributions
13975 ! to the appropriate components of the Cartesian gradient.
13976               call sc_grad_scale(sss)
13977             endif
13978           enddo      ! j
13979         enddo        ! iint
13980       enddo          ! i
13981 !     stop
13982       return
13983       end subroutine ebp_short
13984 !-----------------------------------------------------------------------------
13985       subroutine egb_long(evdw)
13986 !
13987 ! This subroutine calculates the interaction energy of nonbonded side chains
13988 ! assuming the Gay-Berne potential of interaction.
13989 !
13990       use calc_data
13991 !      implicit real*8 (a-h,o-z)
13992 !      include 'DIMENSIONS'
13993 !      include 'COMMON.GEO'
13994 !      include 'COMMON.VAR'
13995 !      include 'COMMON.LOCAL'
13996 !      include 'COMMON.CHAIN'
13997 !      include 'COMMON.DERIV'
13998 !      include 'COMMON.NAMES'
13999 !      include 'COMMON.INTERACT'
14000 !      include 'COMMON.IOUNITS'
14001 !      include 'COMMON.CALC'
14002 !      include 'COMMON.CONTROL'
14003       logical :: lprn
14004 !el local variables
14005       integer :: iint,itypi,itypi1,itypj,subchap
14006       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
14007       real(kind=8) :: sss,e1,e2,evdw,sss_grad
14008       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14009                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14010                     ssgradlipi,ssgradlipj
14011
14012
14013       evdw=0.0D0
14014 !cccc      energy_dec=.false.
14015 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14016       evdw=0.0D0
14017       lprn=.false.
14018 !     if (icall.eq.0) lprn=.false.
14019 !el      ind=0
14020       do i=iatsc_s,iatsc_e
14021         itypi=itype(i,1)
14022         if (itypi.eq.ntyp1) cycle
14023         itypi1=itype(i+1,1)
14024         xi=c(1,nres+i)
14025         yi=c(2,nres+i)
14026         zi=c(3,nres+i)
14027           xi=mod(xi,boxxsize)
14028           if (xi.lt.0) xi=xi+boxxsize
14029           yi=mod(yi,boxysize)
14030           if (yi.lt.0) yi=yi+boxysize
14031           zi=mod(zi,boxzsize)
14032           if (zi.lt.0) zi=zi+boxzsize
14033        if ((zi.gt.bordlipbot)    &
14034         .and.(zi.lt.bordliptop)) then
14035 !C the energy transfer exist
14036         if (zi.lt.buflipbot) then
14037 !C what fraction I am in
14038          fracinbuf=1.0d0-    &
14039              ((zi-bordlipbot)/lipbufthick)
14040 !C lipbufthick is thickenes of lipid buffore
14041          sslipi=sscalelip(fracinbuf)
14042          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14043         elseif (zi.gt.bufliptop) then
14044          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14045          sslipi=sscalelip(fracinbuf)
14046          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14047         else
14048          sslipi=1.0d0
14049          ssgradlipi=0.0
14050         endif
14051        else
14052          sslipi=0.0d0
14053          ssgradlipi=0.0
14054        endif
14055
14056         dxi=dc_norm(1,nres+i)
14057         dyi=dc_norm(2,nres+i)
14058         dzi=dc_norm(3,nres+i)
14059 !        dsci_inv=dsc_inv(itypi)
14060         dsci_inv=vbld_inv(i+nres)
14061 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14062 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14063 !
14064 ! Calculate SC interaction energy.
14065 !
14066         do iint=1,nint_gr(i)
14067           do j=istart(i,iint),iend(i,iint)
14068             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14069 !              call dyn_ssbond_ene(i,j,evdwij)
14070 !              evdw=evdw+evdwij
14071 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14072 !                              'evdw',i,j,evdwij,' ss'
14073 !              if (energy_dec) write (iout,*) &
14074 !                              'evdw',i,j,evdwij,' ss'
14075 !             do k=j+1,iend(i,iint)
14076 !C search over all next residues
14077 !              if (dyn_ss_mask(k)) then
14078 !C check if they are cysteins
14079 !C              write(iout,*) 'k=',k
14080
14081 !c              write(iout,*) "PRZED TRI", evdwij
14082 !               evdwij_przed_tri=evdwij
14083 !              call triple_ssbond_ene(i,j,k,evdwij)
14084 !c               if(evdwij_przed_tri.ne.evdwij) then
14085 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14086 !c               endif
14087
14088 !c              write(iout,*) "PO TRI", evdwij
14089 !C call the energy function that removes the artifical triple disulfide
14090 !C bond the soubroutine is located in ssMD.F
14091 !              evdw=evdw+evdwij
14092               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14093                             'evdw',i,j,evdwij,'tss'
14094 !              endif!dyn_ss_mask(k)
14095 !             enddo! k
14096
14097             ELSE
14098 !el            ind=ind+1
14099             itypj=itype(j,1)
14100             if (itypj.eq.ntyp1) cycle
14101 !            dscj_inv=dsc_inv(itypj)
14102             dscj_inv=vbld_inv(j+nres)
14103 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14104 !     &       1.0d0/vbld(j+nres)
14105 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14106             sig0ij=sigma(itypi,itypj)
14107             chi1=chi(itypi,itypj)
14108             chi2=chi(itypj,itypi)
14109             chi12=chi1*chi2
14110             chip1=chip(itypi)
14111             chip2=chip(itypj)
14112             chip12=chip1*chip2
14113             alf1=alp(itypi)
14114             alf2=alp(itypj)
14115             alf12=0.5D0*(alf1+alf2)
14116             xj=c(1,nres+j)
14117             yj=c(2,nres+j)
14118             zj=c(3,nres+j)
14119 ! Searching for nearest neighbour
14120           xj=mod(xj,boxxsize)
14121           if (xj.lt.0) xj=xj+boxxsize
14122           yj=mod(yj,boxysize)
14123           if (yj.lt.0) yj=yj+boxysize
14124           zj=mod(zj,boxzsize)
14125           if (zj.lt.0) zj=zj+boxzsize
14126        if ((zj.gt.bordlipbot)   &
14127       .and.(zj.lt.bordliptop)) then
14128 !C the energy transfer exist
14129         if (zj.lt.buflipbot) then
14130 !C what fraction I am in
14131          fracinbuf=1.0d0-  &
14132              ((zj-bordlipbot)/lipbufthick)
14133 !C lipbufthick is thickenes of lipid buffore
14134          sslipj=sscalelip(fracinbuf)
14135          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14136         elseif (zj.gt.bufliptop) then
14137          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14138          sslipj=sscalelip(fracinbuf)
14139          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14140         else
14141          sslipj=1.0d0
14142          ssgradlipj=0.0
14143         endif
14144        else
14145          sslipj=0.0d0
14146          ssgradlipj=0.0
14147        endif
14148       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14149        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14150       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14151        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14152
14153           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14154           xj_safe=xj
14155           yj_safe=yj
14156           zj_safe=zj
14157           subchap=0
14158           do xshift=-1,1
14159           do yshift=-1,1
14160           do zshift=-1,1
14161           xj=xj_safe+xshift*boxxsize
14162           yj=yj_safe+yshift*boxysize
14163           zj=zj_safe+zshift*boxzsize
14164           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14165           if(dist_temp.lt.dist_init) then
14166             dist_init=dist_temp
14167             xj_temp=xj
14168             yj_temp=yj
14169             zj_temp=zj
14170             subchap=1
14171           endif
14172           enddo
14173           enddo
14174           enddo
14175           if (subchap.eq.1) then
14176           xj=xj_temp-xi
14177           yj=yj_temp-yi
14178           zj=zj_temp-zi
14179           else
14180           xj=xj_safe-xi
14181           yj=yj_safe-yi
14182           zj=zj_safe-zi
14183           endif
14184
14185             dxj=dc_norm(1,nres+j)
14186             dyj=dc_norm(2,nres+j)
14187             dzj=dc_norm(3,nres+j)
14188             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14189             rij=dsqrt(rrij)
14190             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14191             sss_ele_cut=sscale_ele(1.0d0/(rij))
14192             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14193             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14194             if (sss_ele_cut.le.0.0) cycle
14195             if (sss.lt.1.0d0) then
14196
14197 ! Calculate angle-dependent terms of energy and contributions to their
14198 ! derivatives.
14199               call sc_angular
14200               sigsq=1.0D0/sigsq
14201               sig=sig0ij*dsqrt(sigsq)
14202               rij_shift=1.0D0/rij-sig+sig0ij
14203 ! for diagnostics; uncomment
14204 !              rij_shift=1.2*sig0ij
14205 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14206               if (rij_shift.le.0.0D0) then
14207                 evdw=1.0D20
14208 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14209 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14210 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14211                 return
14212               endif
14213               sigder=-sig*sigsq
14214 !---------------------------------------------------------------
14215               rij_shift=1.0D0/rij_shift
14216               fac=rij_shift**expon
14217               e1=fac*fac*aa
14218               e2=fac*bb
14219               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14220               eps2der=evdwij*eps3rt
14221               eps3der=evdwij*eps2rt
14222 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14223 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14224               evdwij=evdwij*eps2rt*eps3rt
14225               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14226               if (lprn) then
14227               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14228               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14229               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14230                 restyp(itypi,1),i,restyp(itypj,1),j,&
14231                 epsi,sigm,chi1,chi2,chip1,chip2,&
14232                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14233                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14234                 evdwij
14235               endif
14236
14237               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14238                               'evdw',i,j,evdwij
14239 !              if (energy_dec) write (iout,*) &
14240 !                              'evdw',i,j,evdwij,"egb_long"
14241
14242 ! Calculate gradient components.
14243               e1=e1*eps1*eps2rt**2*eps3rt**2
14244               fac=-expon*(e1+evdwij)*rij_shift
14245               sigder=fac*sigder
14246               fac=rij*fac
14247               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14248               *rij-sss_grad/(1.0-sss)*rij  &
14249             /sigmaii(itypi,itypj))
14250 !              fac=0.0d0
14251 ! Calculate the radial part of the gradient
14252               gg(1)=xj*fac
14253               gg(2)=yj*fac
14254               gg(3)=zj*fac
14255 ! Calculate angular part of the gradient.
14256               call sc_grad_scale(1.0d0-sss)
14257             ENDIF    !mask_dyn_ss
14258             endif
14259           enddo      ! j
14260         enddo        ! iint
14261       enddo          ! i
14262 !      write (iout,*) "Number of loop steps in EGB:",ind
14263 !ccc      energy_dec=.false.
14264       return
14265       end subroutine egb_long
14266 !-----------------------------------------------------------------------------
14267       subroutine egb_short(evdw)
14268 !
14269 ! This subroutine calculates the interaction energy of nonbonded side chains
14270 ! assuming the Gay-Berne potential of interaction.
14271 !
14272       use calc_data
14273 !      implicit real*8 (a-h,o-z)
14274 !      include 'DIMENSIONS'
14275 !      include 'COMMON.GEO'
14276 !      include 'COMMON.VAR'
14277 !      include 'COMMON.LOCAL'
14278 !      include 'COMMON.CHAIN'
14279 !      include 'COMMON.DERIV'
14280 !      include 'COMMON.NAMES'
14281 !      include 'COMMON.INTERACT'
14282 !      include 'COMMON.IOUNITS'
14283 !      include 'COMMON.CALC'
14284 !      include 'COMMON.CONTROL'
14285       logical :: lprn
14286 !el local variables
14287       integer :: iint,itypi,itypi1,itypj,subchap
14288       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14289       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14290       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14291                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14292                     ssgradlipi,ssgradlipj
14293       evdw=0.0D0
14294 !cccc      energy_dec=.false.
14295 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14296       evdw=0.0D0
14297       lprn=.false.
14298 !     if (icall.eq.0) lprn=.false.
14299 !el      ind=0
14300       do i=iatsc_s,iatsc_e
14301         itypi=itype(i,1)
14302         if (itypi.eq.ntyp1) cycle
14303         itypi1=itype(i+1,1)
14304         xi=c(1,nres+i)
14305         yi=c(2,nres+i)
14306         zi=c(3,nres+i)
14307           xi=mod(xi,boxxsize)
14308           if (xi.lt.0) xi=xi+boxxsize
14309           yi=mod(yi,boxysize)
14310           if (yi.lt.0) yi=yi+boxysize
14311           zi=mod(zi,boxzsize)
14312           if (zi.lt.0) zi=zi+boxzsize
14313        if ((zi.gt.bordlipbot)    &
14314         .and.(zi.lt.bordliptop)) then
14315 !C the energy transfer exist
14316         if (zi.lt.buflipbot) then
14317 !C what fraction I am in
14318          fracinbuf=1.0d0-    &
14319              ((zi-bordlipbot)/lipbufthick)
14320 !C lipbufthick is thickenes of lipid buffore
14321          sslipi=sscalelip(fracinbuf)
14322          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
14323         elseif (zi.gt.bufliptop) then
14324          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
14325          sslipi=sscalelip(fracinbuf)
14326          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
14327         else
14328          sslipi=1.0d0
14329          ssgradlipi=0.0
14330         endif
14331        else
14332          sslipi=0.0d0
14333          ssgradlipi=0.0
14334        endif
14335
14336         dxi=dc_norm(1,nres+i)
14337         dyi=dc_norm(2,nres+i)
14338         dzi=dc_norm(3,nres+i)
14339 !        dsci_inv=dsc_inv(itypi)
14340         dsci_inv=vbld_inv(i+nres)
14341
14342         dxi=dc_norm(1,nres+i)
14343         dyi=dc_norm(2,nres+i)
14344         dzi=dc_norm(3,nres+i)
14345 !        dsci_inv=dsc_inv(itypi)
14346         dsci_inv=vbld_inv(i+nres)
14347 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14348 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14349 !
14350 ! Calculate SC interaction energy.
14351 !
14352         do iint=1,nint_gr(i)
14353           do j=istart(i,iint),iend(i,iint)
14354             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14355               call dyn_ssbond_ene(i,j,evdwij)
14356               evdw=evdw+evdwij
14357               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14358                               'evdw',i,j,evdwij,' ss'
14359              do k=j+1,iend(i,iint)
14360 !C search over all next residues
14361               if (dyn_ss_mask(k)) then
14362 !C check if they are cysteins
14363 !C              write(iout,*) 'k=',k
14364
14365 !c              write(iout,*) "PRZED TRI", evdwij
14366 !               evdwij_przed_tri=evdwij
14367               call triple_ssbond_ene(i,j,k,evdwij)
14368 !c               if(evdwij_przed_tri.ne.evdwij) then
14369 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14370 !c               endif
14371
14372 !c              write(iout,*) "PO TRI", evdwij
14373 !C call the energy function that removes the artifical triple disulfide
14374 !C bond the soubroutine is located in ssMD.F
14375               evdw=evdw+evdwij
14376               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14377                             'evdw',i,j,evdwij,'tss'
14378               endif!dyn_ss_mask(k)
14379              enddo! k
14380
14381 !              if (energy_dec) write (iout,*) &
14382 !                              'evdw',i,j,evdwij,' ss'
14383             ELSE
14384 !el            ind=ind+1
14385             itypj=itype(j,1)
14386             if (itypj.eq.ntyp1) cycle
14387 !            dscj_inv=dsc_inv(itypj)
14388             dscj_inv=vbld_inv(j+nres)
14389 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14390 !     &       1.0d0/vbld(j+nres)
14391 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14392             sig0ij=sigma(itypi,itypj)
14393             chi1=chi(itypi,itypj)
14394             chi2=chi(itypj,itypi)
14395             chi12=chi1*chi2
14396             chip1=chip(itypi)
14397             chip2=chip(itypj)
14398             chip12=chip1*chip2
14399             alf1=alp(itypi)
14400             alf2=alp(itypj)
14401             alf12=0.5D0*(alf1+alf2)
14402 !            xj=c(1,nres+j)-xi
14403 !            yj=c(2,nres+j)-yi
14404 !            zj=c(3,nres+j)-zi
14405             xj=c(1,nres+j)
14406             yj=c(2,nres+j)
14407             zj=c(3,nres+j)
14408 ! Searching for nearest neighbour
14409           xj=mod(xj,boxxsize)
14410           if (xj.lt.0) xj=xj+boxxsize
14411           yj=mod(yj,boxysize)
14412           if (yj.lt.0) yj=yj+boxysize
14413           zj=mod(zj,boxzsize)
14414           if (zj.lt.0) zj=zj+boxzsize
14415        if ((zj.gt.bordlipbot)   &
14416       .and.(zj.lt.bordliptop)) then
14417 !C the energy transfer exist
14418         if (zj.lt.buflipbot) then
14419 !C what fraction I am in
14420          fracinbuf=1.0d0-  &
14421              ((zj-bordlipbot)/lipbufthick)
14422 !C lipbufthick is thickenes of lipid buffore
14423          sslipj=sscalelip(fracinbuf)
14424          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
14425         elseif (zj.gt.bufliptop) then
14426          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
14427          sslipj=sscalelip(fracinbuf)
14428          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
14429         else
14430          sslipj=1.0d0
14431          ssgradlipj=0.0
14432         endif
14433        else
14434          sslipj=0.0d0
14435          ssgradlipj=0.0
14436        endif
14437       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14438        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14439       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14440        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14441
14442           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14443           xj_safe=xj
14444           yj_safe=yj
14445           zj_safe=zj
14446           subchap=0
14447
14448           do xshift=-1,1
14449           do yshift=-1,1
14450           do zshift=-1,1
14451           xj=xj_safe+xshift*boxxsize
14452           yj=yj_safe+yshift*boxysize
14453           zj=zj_safe+zshift*boxzsize
14454           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14455           if(dist_temp.lt.dist_init) then
14456             dist_init=dist_temp
14457             xj_temp=xj
14458             yj_temp=yj
14459             zj_temp=zj
14460             subchap=1
14461           endif
14462           enddo
14463           enddo
14464           enddo
14465           if (subchap.eq.1) then
14466           xj=xj_temp-xi
14467           yj=yj_temp-yi
14468           zj=zj_temp-zi
14469           else
14470           xj=xj_safe-xi
14471           yj=yj_safe-yi
14472           zj=zj_safe-zi
14473           endif
14474
14475             dxj=dc_norm(1,nres+j)
14476             dyj=dc_norm(2,nres+j)
14477             dzj=dc_norm(3,nres+j)
14478             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14479             rij=dsqrt(rrij)
14480             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14481             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14482             sss_ele_cut=sscale_ele(1.0d0/(rij))
14483             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14484             if (sss_ele_cut.le.0.0) cycle
14485
14486             if (sss.gt.0.0d0) then
14487
14488 ! Calculate angle-dependent terms of energy and contributions to their
14489 ! derivatives.
14490               call sc_angular
14491               sigsq=1.0D0/sigsq
14492               sig=sig0ij*dsqrt(sigsq)
14493               rij_shift=1.0D0/rij-sig+sig0ij
14494 ! for diagnostics; uncomment
14495 !              rij_shift=1.2*sig0ij
14496 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14497               if (rij_shift.le.0.0D0) then
14498                 evdw=1.0D20
14499 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14500 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14501 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14502                 return
14503               endif
14504               sigder=-sig*sigsq
14505 !---------------------------------------------------------------
14506               rij_shift=1.0D0/rij_shift
14507               fac=rij_shift**expon
14508               e1=fac*fac*aa
14509               e2=fac*bb
14510               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14511               eps2der=evdwij*eps3rt
14512               eps3der=evdwij*eps2rt
14513 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14514 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14515               evdwij=evdwij*eps2rt*eps3rt
14516               evdw=evdw+evdwij*sss*sss_ele_cut
14517               if (lprn) then
14518               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14519               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14520               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14521                 restyp(itypi,1),i,restyp(itypj,1),j,&
14522                 epsi,sigm,chi1,chi2,chip1,chip2,&
14523                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14524                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14525                 evdwij
14526               endif
14527
14528               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14529                               'evdw',i,j,evdwij
14530 !              if (energy_dec) write (iout,*) &
14531 !                              'evdw',i,j,evdwij,"egb_short"
14532
14533 ! Calculate gradient components.
14534               e1=e1*eps1*eps2rt**2*eps3rt**2
14535               fac=-expon*(e1+evdwij)*rij_shift
14536               sigder=fac*sigder
14537               fac=rij*fac
14538               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14539             *rij+sss_grad/sss*rij  &
14540             /sigmaii(itypi,itypj))
14541
14542 !              fac=0.0d0
14543 ! Calculate the radial part of the gradient
14544               gg(1)=xj*fac
14545               gg(2)=yj*fac
14546               gg(3)=zj*fac
14547 ! Calculate angular part of the gradient.
14548               call sc_grad_scale(sss)
14549             endif
14550           ENDIF !mask_dyn_ss
14551           enddo      ! j
14552         enddo        ! iint
14553       enddo          ! i
14554 !      write (iout,*) "Number of loop steps in EGB:",ind
14555 !ccc      energy_dec=.false.
14556       return
14557       end subroutine egb_short
14558 !-----------------------------------------------------------------------------
14559       subroutine egbv_long(evdw)
14560 !
14561 ! This subroutine calculates the interaction energy of nonbonded side chains
14562 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14563 !
14564       use calc_data
14565 !      implicit real*8 (a-h,o-z)
14566 !      include 'DIMENSIONS'
14567 !      include 'COMMON.GEO'
14568 !      include 'COMMON.VAR'
14569 !      include 'COMMON.LOCAL'
14570 !      include 'COMMON.CHAIN'
14571 !      include 'COMMON.DERIV'
14572 !      include 'COMMON.NAMES'
14573 !      include 'COMMON.INTERACT'
14574 !      include 'COMMON.IOUNITS'
14575 !      include 'COMMON.CALC'
14576       use comm_srutu
14577 !el      integer :: icall
14578 !el      common /srutu/ icall
14579       logical :: lprn
14580 !el local variables
14581       integer :: iint,itypi,itypi1,itypj
14582       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
14583       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14584       evdw=0.0D0
14585 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14586       evdw=0.0D0
14587       lprn=.false.
14588 !     if (icall.eq.0) lprn=.true.
14589 !el      ind=0
14590       do i=iatsc_s,iatsc_e
14591         itypi=itype(i,1)
14592         if (itypi.eq.ntyp1) cycle
14593         itypi1=itype(i+1,1)
14594         xi=c(1,nres+i)
14595         yi=c(2,nres+i)
14596         zi=c(3,nres+i)
14597         dxi=dc_norm(1,nres+i)
14598         dyi=dc_norm(2,nres+i)
14599         dzi=dc_norm(3,nres+i)
14600 !        dsci_inv=dsc_inv(itypi)
14601         dsci_inv=vbld_inv(i+nres)
14602 !
14603 ! Calculate SC interaction energy.
14604 !
14605         do iint=1,nint_gr(i)
14606           do j=istart(i,iint),iend(i,iint)
14607 !el            ind=ind+1
14608             itypj=itype(j,1)
14609             if (itypj.eq.ntyp1) cycle
14610 !            dscj_inv=dsc_inv(itypj)
14611             dscj_inv=vbld_inv(j+nres)
14612             sig0ij=sigma(itypi,itypj)
14613             r0ij=r0(itypi,itypj)
14614             chi1=chi(itypi,itypj)
14615             chi2=chi(itypj,itypi)
14616             chi12=chi1*chi2
14617             chip1=chip(itypi)
14618             chip2=chip(itypj)
14619             chip12=chip1*chip2
14620             alf1=alp(itypi)
14621             alf2=alp(itypj)
14622             alf12=0.5D0*(alf1+alf2)
14623             xj=c(1,nres+j)-xi
14624             yj=c(2,nres+j)-yi
14625             zj=c(3,nres+j)-zi
14626             dxj=dc_norm(1,nres+j)
14627             dyj=dc_norm(2,nres+j)
14628             dzj=dc_norm(3,nres+j)
14629             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14630             rij=dsqrt(rrij)
14631
14632             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14633
14634             if (sss.lt.1.0d0) then
14635
14636 ! Calculate angle-dependent terms of energy and contributions to their
14637 ! derivatives.
14638               call sc_angular
14639               sigsq=1.0D0/sigsq
14640               sig=sig0ij*dsqrt(sigsq)
14641               rij_shift=1.0D0/rij-sig+r0ij
14642 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14643               if (rij_shift.le.0.0D0) then
14644                 evdw=1.0D20
14645                 return
14646               endif
14647               sigder=-sig*sigsq
14648 !---------------------------------------------------------------
14649               rij_shift=1.0D0/rij_shift
14650               fac=rij_shift**expon
14651               e1=fac*fac*aa_aq(itypi,itypj)
14652               e2=fac*bb_aq(itypi,itypj)
14653               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14654               eps2der=evdwij*eps3rt
14655               eps3der=evdwij*eps2rt
14656               fac_augm=rrij**expon
14657               e_augm=augm(itypi,itypj)*fac_augm
14658               evdwij=evdwij*eps2rt*eps3rt
14659               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14660               if (lprn) then
14661               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14662               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14663               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14664                 restyp(itypi,1),i,restyp(itypj,1),j,&
14665                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14666                 chi1,chi2,chip1,chip2,&
14667                 eps1,eps2rt**2,eps3rt**2,&
14668                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14669                 evdwij+e_augm
14670               endif
14671 ! Calculate gradient components.
14672               e1=e1*eps1*eps2rt**2*eps3rt**2
14673               fac=-expon*(e1+evdwij)*rij_shift
14674               sigder=fac*sigder
14675               fac=rij*fac-2*expon*rrij*e_augm
14676 ! Calculate the radial part of the gradient
14677               gg(1)=xj*fac
14678               gg(2)=yj*fac
14679               gg(3)=zj*fac
14680 ! Calculate angular part of the gradient.
14681               call sc_grad_scale(1.0d0-sss)
14682             endif
14683           enddo      ! j
14684         enddo        ! iint
14685       enddo          ! i
14686       end subroutine egbv_long
14687 !-----------------------------------------------------------------------------
14688       subroutine egbv_short(evdw)
14689 !
14690 ! This subroutine calculates the interaction energy of nonbonded side chains
14691 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14692 !
14693       use calc_data
14694 !      implicit real*8 (a-h,o-z)
14695 !      include 'DIMENSIONS'
14696 !      include 'COMMON.GEO'
14697 !      include 'COMMON.VAR'
14698 !      include 'COMMON.LOCAL'
14699 !      include 'COMMON.CHAIN'
14700 !      include 'COMMON.DERIV'
14701 !      include 'COMMON.NAMES'
14702 !      include 'COMMON.INTERACT'
14703 !      include 'COMMON.IOUNITS'
14704 !      include 'COMMON.CALC'
14705       use comm_srutu
14706 !el      integer :: icall
14707 !el      common /srutu/ icall
14708       logical :: lprn
14709 !el local variables
14710       integer :: iint,itypi,itypi1,itypj
14711       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14712       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14713       evdw=0.0D0
14714 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14715       evdw=0.0D0
14716       lprn=.false.
14717 !     if (icall.eq.0) lprn=.true.
14718 !el      ind=0
14719       do i=iatsc_s,iatsc_e
14720         itypi=itype(i,1)
14721         if (itypi.eq.ntyp1) cycle
14722         itypi1=itype(i+1,1)
14723         xi=c(1,nres+i)
14724         yi=c(2,nres+i)
14725         zi=c(3,nres+i)
14726         dxi=dc_norm(1,nres+i)
14727         dyi=dc_norm(2,nres+i)
14728         dzi=dc_norm(3,nres+i)
14729 !        dsci_inv=dsc_inv(itypi)
14730         dsci_inv=vbld_inv(i+nres)
14731 !
14732 ! Calculate SC interaction energy.
14733 !
14734         do iint=1,nint_gr(i)
14735           do j=istart(i,iint),iend(i,iint)
14736 !el            ind=ind+1
14737             itypj=itype(j,1)
14738             if (itypj.eq.ntyp1) cycle
14739 !            dscj_inv=dsc_inv(itypj)
14740             dscj_inv=vbld_inv(j+nres)
14741             sig0ij=sigma(itypi,itypj)
14742             r0ij=r0(itypi,itypj)
14743             chi1=chi(itypi,itypj)
14744             chi2=chi(itypj,itypi)
14745             chi12=chi1*chi2
14746             chip1=chip(itypi)
14747             chip2=chip(itypj)
14748             chip12=chip1*chip2
14749             alf1=alp(itypi)
14750             alf2=alp(itypj)
14751             alf12=0.5D0*(alf1+alf2)
14752             xj=c(1,nres+j)-xi
14753             yj=c(2,nres+j)-yi
14754             zj=c(3,nres+j)-zi
14755             dxj=dc_norm(1,nres+j)
14756             dyj=dc_norm(2,nres+j)
14757             dzj=dc_norm(3,nres+j)
14758             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14759             rij=dsqrt(rrij)
14760
14761             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14762
14763             if (sss.gt.0.0d0) then
14764
14765 ! Calculate angle-dependent terms of energy and contributions to their
14766 ! derivatives.
14767               call sc_angular
14768               sigsq=1.0D0/sigsq
14769               sig=sig0ij*dsqrt(sigsq)
14770               rij_shift=1.0D0/rij-sig+r0ij
14771 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14772               if (rij_shift.le.0.0D0) then
14773                 evdw=1.0D20
14774                 return
14775               endif
14776               sigder=-sig*sigsq
14777 !---------------------------------------------------------------
14778               rij_shift=1.0D0/rij_shift
14779               fac=rij_shift**expon
14780               e1=fac*fac*aa_aq(itypi,itypj)
14781               e2=fac*bb_aq(itypi,itypj)
14782               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14783               eps2der=evdwij*eps3rt
14784               eps3der=evdwij*eps2rt
14785               fac_augm=rrij**expon
14786               e_augm=augm(itypi,itypj)*fac_augm
14787               evdwij=evdwij*eps2rt*eps3rt
14788               evdw=evdw+(evdwij+e_augm)*sss
14789               if (lprn) then
14790               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14791               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14792               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14793                 restyp(itypi,1),i,restyp(itypj,1),j,&
14794                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14795                 chi1,chi2,chip1,chip2,&
14796                 eps1,eps2rt**2,eps3rt**2,&
14797                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14798                 evdwij+e_augm
14799               endif
14800 ! Calculate gradient components.
14801               e1=e1*eps1*eps2rt**2*eps3rt**2
14802               fac=-expon*(e1+evdwij)*rij_shift
14803               sigder=fac*sigder
14804               fac=rij*fac-2*expon*rrij*e_augm
14805 ! Calculate the radial part of the gradient
14806               gg(1)=xj*fac
14807               gg(2)=yj*fac
14808               gg(3)=zj*fac
14809 ! Calculate angular part of the gradient.
14810               call sc_grad_scale(sss)
14811             endif
14812           enddo      ! j
14813         enddo        ! iint
14814       enddo          ! i
14815       end subroutine egbv_short
14816 !-----------------------------------------------------------------------------
14817       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14818 !
14819 ! This subroutine calculates the average interaction energy and its gradient
14820 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14821 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14822 ! The potential depends both on the distance of peptide-group centers and on
14823 ! the orientation of the CA-CA virtual bonds.
14824 !
14825 !      implicit real*8 (a-h,o-z)
14826
14827       use comm_locel
14828 #ifdef MPI
14829       include 'mpif.h'
14830 #endif
14831 !      include 'DIMENSIONS'
14832 !      include 'COMMON.CONTROL'
14833 !      include 'COMMON.SETUP'
14834 !      include 'COMMON.IOUNITS'
14835 !      include 'COMMON.GEO'
14836 !      include 'COMMON.VAR'
14837 !      include 'COMMON.LOCAL'
14838 !      include 'COMMON.CHAIN'
14839 !      include 'COMMON.DERIV'
14840 !      include 'COMMON.INTERACT'
14841 !      include 'COMMON.CONTACTS'
14842 !      include 'COMMON.TORSION'
14843 !      include 'COMMON.VECTORS'
14844 !      include 'COMMON.FFIELD'
14845 !      include 'COMMON.TIME1'
14846       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14847       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14848       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14849 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14850       real(kind=8),dimension(4) :: muij
14851 !el      integer :: num_conti,j1,j2
14852 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14853 !el                   dz_normi,xmedi,ymedi,zmedi
14854 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14855 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14856 !el          num_conti,j1,j2
14857 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14858 #ifdef MOMENT
14859       real(kind=8) :: scal_el=1.0d0
14860 #else
14861       real(kind=8) :: scal_el=0.5d0
14862 #endif
14863 ! 12/13/98
14864 ! 13-go grudnia roku pamietnego...
14865       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14866                                              0.0d0,1.0d0,0.0d0,&
14867                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14868 !el local variables
14869       integer :: i,j,k
14870       real(kind=8) :: fac
14871       real(kind=8) :: dxj,dyj,dzj
14872       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14873
14874 !      allocate(num_cont_hb(nres)) !(maxres)
14875 !d      write(iout,*) 'In EELEC'
14876 !d      do i=1,nloctyp
14877 !d        write(iout,*) 'Type',i
14878 !d        write(iout,*) 'B1',B1(:,i)
14879 !d        write(iout,*) 'B2',B2(:,i)
14880 !d        write(iout,*) 'CC',CC(:,:,i)
14881 !d        write(iout,*) 'DD',DD(:,:,i)
14882 !d        write(iout,*) 'EE',EE(:,:,i)
14883 !d      enddo
14884 !d      call check_vecgrad
14885 !d      stop
14886       if (icheckgrad.eq.1) then
14887         do i=1,nres-1
14888           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14889           do k=1,3
14890             dc_norm(k,i)=dc(k,i)*fac
14891           enddo
14892 !          write (iout,*) 'i',i,' fac',fac
14893         enddo
14894       endif
14895       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14896           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14897           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14898 !        call vec_and_deriv
14899 #ifdef TIMING
14900         time01=MPI_Wtime()
14901 #endif
14902 !        print *, "before set matrices"
14903         call set_matrices
14904 !        print *,"after set martices"
14905 #ifdef TIMING
14906         time_mat=time_mat+MPI_Wtime()-time01
14907 #endif
14908       endif
14909 !d      do i=1,nres-1
14910 !d        write (iout,*) 'i=',i
14911 !d        do k=1,3
14912 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14913 !d        enddo
14914 !d        do k=1,3
14915 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14916 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14917 !d        enddo
14918 !d      enddo
14919       t_eelecij=0.0d0
14920       ees=0.0D0
14921       evdw1=0.0D0
14922       eel_loc=0.0d0
14923       eello_turn3=0.0d0
14924       eello_turn4=0.0d0
14925 !el      ind=0
14926       do i=1,nres
14927         num_cont_hb(i)=0
14928       enddo
14929 !d      print '(a)','Enter EELEC'
14930 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14931 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14932 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14933       do i=1,nres
14934         gel_loc_loc(i)=0.0d0
14935         gcorr_loc(i)=0.0d0
14936       enddo
14937 !
14938 !
14939 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14940 !
14941 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14942 !
14943       do i=iturn3_start,iturn3_end
14944         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14945         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14946         dxi=dc(1,i)
14947         dyi=dc(2,i)
14948         dzi=dc(3,i)
14949         dx_normi=dc_norm(1,i)
14950         dy_normi=dc_norm(2,i)
14951         dz_normi=dc_norm(3,i)
14952         xmedi=c(1,i)+0.5d0*dxi
14953         ymedi=c(2,i)+0.5d0*dyi
14954         zmedi=c(3,i)+0.5d0*dzi
14955           xmedi=dmod(xmedi,boxxsize)
14956           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14957           ymedi=dmod(ymedi,boxysize)
14958           if (ymedi.lt.0) ymedi=ymedi+boxysize
14959           zmedi=dmod(zmedi,boxzsize)
14960           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14961         num_conti=0
14962         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14963         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14964         num_cont_hb(i)=num_conti
14965       enddo
14966       do i=iturn4_start,iturn4_end
14967         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14968           .or. itype(i+3,1).eq.ntyp1 &
14969           .or. itype(i+4,1).eq.ntyp1) cycle
14970         dxi=dc(1,i)
14971         dyi=dc(2,i)
14972         dzi=dc(3,i)
14973         dx_normi=dc_norm(1,i)
14974         dy_normi=dc_norm(2,i)
14975         dz_normi=dc_norm(3,i)
14976         xmedi=c(1,i)+0.5d0*dxi
14977         ymedi=c(2,i)+0.5d0*dyi
14978         zmedi=c(3,i)+0.5d0*dzi
14979           xmedi=dmod(xmedi,boxxsize)
14980           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14981           ymedi=dmod(ymedi,boxysize)
14982           if (ymedi.lt.0) ymedi=ymedi+boxysize
14983           zmedi=dmod(zmedi,boxzsize)
14984           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14985         num_conti=num_cont_hb(i)
14986         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14987         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14988           call eturn4(i,eello_turn4)
14989         num_cont_hb(i)=num_conti
14990       enddo   ! i
14991 !
14992 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14993 !
14994       do i=iatel_s,iatel_e
14995         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14996         dxi=dc(1,i)
14997         dyi=dc(2,i)
14998         dzi=dc(3,i)
14999         dx_normi=dc_norm(1,i)
15000         dy_normi=dc_norm(2,i)
15001         dz_normi=dc_norm(3,i)
15002         xmedi=c(1,i)+0.5d0*dxi
15003         ymedi=c(2,i)+0.5d0*dyi
15004         zmedi=c(3,i)+0.5d0*dzi
15005           xmedi=dmod(xmedi,boxxsize)
15006           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15007           ymedi=dmod(ymedi,boxysize)
15008           if (ymedi.lt.0) ymedi=ymedi+boxysize
15009           zmedi=dmod(zmedi,boxzsize)
15010           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15011 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15012         num_conti=num_cont_hb(i)
15013         do j=ielstart(i),ielend(i)
15014           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15015           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15016         enddo ! j
15017         num_cont_hb(i)=num_conti
15018       enddo   ! i
15019 !      write (iout,*) "Number of loop steps in EELEC:",ind
15020 !d      do i=1,nres
15021 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15022 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15023 !d      enddo
15024 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15025 !cc      eel_loc=eel_loc+eello_turn3
15026 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15027       return
15028       end subroutine eelec_scale
15029 !-----------------------------------------------------------------------------
15030       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15031 !      implicit real*8 (a-h,o-z)
15032
15033       use comm_locel
15034 !      include 'DIMENSIONS'
15035 #ifdef MPI
15036       include "mpif.h"
15037 #endif
15038 !      include 'COMMON.CONTROL'
15039 !      include 'COMMON.IOUNITS'
15040 !      include 'COMMON.GEO'
15041 !      include 'COMMON.VAR'
15042 !      include 'COMMON.LOCAL'
15043 !      include 'COMMON.CHAIN'
15044 !      include 'COMMON.DERIV'
15045 !      include 'COMMON.INTERACT'
15046 !      include 'COMMON.CONTACTS'
15047 !      include 'COMMON.TORSION'
15048 !      include 'COMMON.VECTORS'
15049 !      include 'COMMON.FFIELD'
15050 !      include 'COMMON.TIME1'
15051       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15052       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15053       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15054 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15055       real(kind=8),dimension(4) :: muij
15056       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15057                     dist_temp, dist_init,sss_grad
15058       integer xshift,yshift,zshift
15059
15060 !el      integer :: num_conti,j1,j2
15061 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15062 !el                   dz_normi,xmedi,ymedi,zmedi
15063 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15064 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15065 !el          num_conti,j1,j2
15066 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15067 #ifdef MOMENT
15068       real(kind=8) :: scal_el=1.0d0
15069 #else
15070       real(kind=8) :: scal_el=0.5d0
15071 #endif
15072 ! 12/13/98
15073 ! 13-go grudnia roku pamietnego...
15074       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15075                                              0.0d0,1.0d0,0.0d0,&
15076                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15077 !el local variables
15078       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15079       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15080       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15081       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15082       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15083       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15084       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15085                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15086                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15087                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15088                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15089                   ecosam,ecosbm,ecosgm,ghalf,time00
15090 !      integer :: maxconts
15091 !      maxconts = nres/4
15092 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15093 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15094 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15095 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15096 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15097 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15098 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15099 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15100 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15101 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15102 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15103 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15104 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15105
15106 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15107 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15108
15109 #ifdef MPI
15110           time00=MPI_Wtime()
15111 #endif
15112 !d      write (iout,*) "eelecij",i,j
15113 !el          ind=ind+1
15114           iteli=itel(i)
15115           itelj=itel(j)
15116           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15117           aaa=app(iteli,itelj)
15118           bbb=bpp(iteli,itelj)
15119           ael6i=ael6(iteli,itelj)
15120           ael3i=ael3(iteli,itelj)
15121           dxj=dc(1,j)
15122           dyj=dc(2,j)
15123           dzj=dc(3,j)
15124           dx_normj=dc_norm(1,j)
15125           dy_normj=dc_norm(2,j)
15126           dz_normj=dc_norm(3,j)
15127 !          xj=c(1,j)+0.5D0*dxj-xmedi
15128 !          yj=c(2,j)+0.5D0*dyj-ymedi
15129 !          zj=c(3,j)+0.5D0*dzj-zmedi
15130           xj=c(1,j)+0.5D0*dxj
15131           yj=c(2,j)+0.5D0*dyj
15132           zj=c(3,j)+0.5D0*dzj
15133           xj=mod(xj,boxxsize)
15134           if (xj.lt.0) xj=xj+boxxsize
15135           yj=mod(yj,boxysize)
15136           if (yj.lt.0) yj=yj+boxysize
15137           zj=mod(zj,boxzsize)
15138           if (zj.lt.0) zj=zj+boxzsize
15139       isubchap=0
15140       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15141       xj_safe=xj
15142       yj_safe=yj
15143       zj_safe=zj
15144       do xshift=-1,1
15145       do yshift=-1,1
15146       do zshift=-1,1
15147           xj=xj_safe+xshift*boxxsize
15148           yj=yj_safe+yshift*boxysize
15149           zj=zj_safe+zshift*boxzsize
15150           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15151           if(dist_temp.lt.dist_init) then
15152             dist_init=dist_temp
15153             xj_temp=xj
15154             yj_temp=yj
15155             zj_temp=zj
15156             isubchap=1
15157           endif
15158        enddo
15159        enddo
15160        enddo
15161        if (isubchap.eq.1) then
15162 !C          print *,i,j
15163           xj=xj_temp-xmedi
15164           yj=yj_temp-ymedi
15165           zj=zj_temp-zmedi
15166        else
15167           xj=xj_safe-xmedi
15168           yj=yj_safe-ymedi
15169           zj=zj_safe-zmedi
15170        endif
15171
15172           rij=xj*xj+yj*yj+zj*zj
15173           rrmij=1.0D0/rij
15174           rij=dsqrt(rij)
15175           rmij=1.0D0/rij
15176 ! For extracting the short-range part of Evdwpp
15177           sss=sscale(rij/rpp(iteli,itelj))
15178             sss_ele_cut=sscale_ele(rij)
15179             sss_ele_grad=sscagrad_ele(rij)
15180             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15181 !             sss_ele_cut=1.0d0
15182 !             sss_ele_grad=0.0d0
15183             if (sss_ele_cut.le.0.0) go to 128
15184
15185           r3ij=rrmij*rmij
15186           r6ij=r3ij*r3ij
15187           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15188           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15189           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15190           fac=cosa-3.0D0*cosb*cosg
15191           ev1=aaa*r6ij*r6ij
15192 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15193           if (j.eq.i+2) ev1=scal_el*ev1
15194           ev2=bbb*r6ij
15195           fac3=ael6i*r6ij
15196           fac4=ael3i*r3ij
15197           evdwij=ev1+ev2
15198           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15199           el2=fac4*fac
15200           eesij=el1+el2
15201 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15202           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15203           ees=ees+eesij*sss_ele_cut
15204           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15205 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15206 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15207 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15208 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15209
15210           if (energy_dec) then
15211               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15212               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15213           endif
15214
15215 !
15216 ! Calculate contributions to the Cartesian gradient.
15217 !
15218 #ifdef SPLITELE
15219           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15220           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15221           fac1=fac
15222           erij(1)=xj*rmij
15223           erij(2)=yj*rmij
15224           erij(3)=zj*rmij
15225 !
15226 ! Radial derivatives. First process both termini of the fragment (i,j)
15227 !
15228           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15229           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15230           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15231 !          do k=1,3
15232 !            ghalf=0.5D0*ggg(k)
15233 !            gelc(k,i)=gelc(k,i)+ghalf
15234 !            gelc(k,j)=gelc(k,j)+ghalf
15235 !          enddo
15236 ! 9/28/08 AL Gradient compotents will be summed only at the end
15237           do k=1,3
15238             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15239             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15240           enddo
15241 !
15242 ! Loop over residues i+1 thru j-1.
15243 !
15244 !grad          do k=i+1,j-1
15245 !grad            do l=1,3
15246 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15247 !grad            enddo
15248 !grad          enddo
15249           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15250           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15251           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15252           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15253           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15254           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15255 !          do k=1,3
15256 !            ghalf=0.5D0*ggg(k)
15257 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15258 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15259 !          enddo
15260 ! 9/28/08 AL Gradient compotents will be summed only at the end
15261           do k=1,3
15262             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15263             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15264           enddo
15265 !
15266 ! Loop over residues i+1 thru j-1.
15267 !
15268 !grad          do k=i+1,j-1
15269 !grad            do l=1,3
15270 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15271 !grad            enddo
15272 !grad          enddo
15273 #else
15274           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15275           facel=(el1+eesij)*sss_ele_cut
15276           fac1=fac
15277           fac=-3*rrmij*(facvdw+facvdw+facel)
15278           erij(1)=xj*rmij
15279           erij(2)=yj*rmij
15280           erij(3)=zj*rmij
15281 !
15282 ! Radial derivatives. First process both termini of the fragment (i,j)
15283 !
15284           ggg(1)=fac*xj
15285           ggg(2)=fac*yj
15286           ggg(3)=fac*zj
15287 !          do k=1,3
15288 !            ghalf=0.5D0*ggg(k)
15289 !            gelc(k,i)=gelc(k,i)+ghalf
15290 !            gelc(k,j)=gelc(k,j)+ghalf
15291 !          enddo
15292 ! 9/28/08 AL Gradient compotents will be summed only at the end
15293           do k=1,3
15294             gelc_long(k,j)=gelc(k,j)+ggg(k)
15295             gelc_long(k,i)=gelc(k,i)-ggg(k)
15296           enddo
15297 !
15298 ! Loop over residues i+1 thru j-1.
15299 !
15300 !grad          do k=i+1,j-1
15301 !grad            do l=1,3
15302 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15303 !grad            enddo
15304 !grad          enddo
15305 ! 9/28/08 AL Gradient compotents will be summed only at the end
15306           ggg(1)=facvdw*xj
15307           ggg(2)=facvdw*yj
15308           ggg(3)=facvdw*zj
15309           do k=1,3
15310             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15311             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15312           enddo
15313 #endif
15314 !
15315 ! Angular part
15316 !
15317           ecosa=2.0D0*fac3*fac1+fac4
15318           fac4=-3.0D0*fac4
15319           fac3=-6.0D0*fac3
15320           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15321           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15322           do k=1,3
15323             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15324             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15325           enddo
15326 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15327 !d   &          (dcosg(k),k=1,3)
15328           do k=1,3
15329             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15330           enddo
15331 !          do k=1,3
15332 !            ghalf=0.5D0*ggg(k)
15333 !            gelc(k,i)=gelc(k,i)+ghalf
15334 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15335 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15336 !            gelc(k,j)=gelc(k,j)+ghalf
15337 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15338 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15339 !          enddo
15340 !grad          do k=i+1,j-1
15341 !grad            do l=1,3
15342 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15343 !grad            enddo
15344 !grad          enddo
15345           do k=1,3
15346             gelc(k,i)=gelc(k,i) &
15347                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15348                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15349                      *sss_ele_cut
15350             gelc(k,j)=gelc(k,j) &
15351                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15352                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15353                      *sss_ele_cut
15354             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15355             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15356           enddo
15357           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15358               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15359               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15360 !
15361 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15362 !   energy of a peptide unit is assumed in the form of a second-order
15363 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15364 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15365 !   are computed for EVERY pair of non-contiguous peptide groups.
15366 !
15367           if (j.lt.nres-1) then
15368             j1=j+1
15369             j2=j-1
15370           else
15371             j1=j-1
15372             j2=j-2
15373           endif
15374           kkk=0
15375           do k=1,2
15376             do l=1,2
15377               kkk=kkk+1
15378               muij(kkk)=mu(k,i)*mu(l,j)
15379             enddo
15380           enddo
15381 !d         write (iout,*) 'EELEC: i',i,' j',j
15382 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15383 !d          write(iout,*) 'muij',muij
15384           ury=scalar(uy(1,i),erij)
15385           urz=scalar(uz(1,i),erij)
15386           vry=scalar(uy(1,j),erij)
15387           vrz=scalar(uz(1,j),erij)
15388           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15389           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15390           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15391           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15392           fac=dsqrt(-ael6i)*r3ij
15393           a22=a22*fac
15394           a23=a23*fac
15395           a32=a32*fac
15396           a33=a33*fac
15397 !d          write (iout,'(4i5,4f10.5)')
15398 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15399 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15400 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15401 !d     &      uy(:,j),uz(:,j)
15402 !d          write (iout,'(4f10.5)')
15403 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15404 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15405 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15406 !d           write (iout,'(9f10.5/)')
15407 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15408 ! Derivatives of the elements of A in virtual-bond vectors
15409           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15410           do k=1,3
15411             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15412             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15413             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15414             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15415             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15416             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15417             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15418             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15419             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15420             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15421             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15422             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15423           enddo
15424 ! Compute radial contributions to the gradient
15425           facr=-3.0d0*rrmij
15426           a22der=a22*facr
15427           a23der=a23*facr
15428           a32der=a32*facr
15429           a33der=a33*facr
15430           agg(1,1)=a22der*xj
15431           agg(2,1)=a22der*yj
15432           agg(3,1)=a22der*zj
15433           agg(1,2)=a23der*xj
15434           agg(2,2)=a23der*yj
15435           agg(3,2)=a23der*zj
15436           agg(1,3)=a32der*xj
15437           agg(2,3)=a32der*yj
15438           agg(3,3)=a32der*zj
15439           agg(1,4)=a33der*xj
15440           agg(2,4)=a33der*yj
15441           agg(3,4)=a33der*zj
15442 ! Add the contributions coming from er
15443           fac3=-3.0d0*fac
15444           do k=1,3
15445             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15446             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15447             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15448             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15449           enddo
15450           do k=1,3
15451 ! Derivatives in DC(i)
15452 !grad            ghalf1=0.5d0*agg(k,1)
15453 !grad            ghalf2=0.5d0*agg(k,2)
15454 !grad            ghalf3=0.5d0*agg(k,3)
15455 !grad            ghalf4=0.5d0*agg(k,4)
15456             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15457             -3.0d0*uryg(k,2)*vry)!+ghalf1
15458             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15459             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15460             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15461             -3.0d0*urzg(k,2)*vry)!+ghalf3
15462             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15463             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15464 ! Derivatives in DC(i+1)
15465             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15466             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15467             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15468             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15469             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15470             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15471             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15472             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15473 ! Derivatives in DC(j)
15474             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15475             -3.0d0*vryg(k,2)*ury)!+ghalf1
15476             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15477             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15478             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15479             -3.0d0*vryg(k,2)*urz)!+ghalf3
15480             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15481             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15482 ! Derivatives in DC(j+1) or DC(nres-1)
15483             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15484             -3.0d0*vryg(k,3)*ury)
15485             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15486             -3.0d0*vrzg(k,3)*ury)
15487             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15488             -3.0d0*vryg(k,3)*urz)
15489             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15490             -3.0d0*vrzg(k,3)*urz)
15491 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15492 !grad              do l=1,4
15493 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15494 !grad              enddo
15495 !grad            endif
15496           enddo
15497           acipa(1,1)=a22
15498           acipa(1,2)=a23
15499           acipa(2,1)=a32
15500           acipa(2,2)=a33
15501           a22=-a22
15502           a23=-a23
15503           do l=1,2
15504             do k=1,3
15505               agg(k,l)=-agg(k,l)
15506               aggi(k,l)=-aggi(k,l)
15507               aggi1(k,l)=-aggi1(k,l)
15508               aggj(k,l)=-aggj(k,l)
15509               aggj1(k,l)=-aggj1(k,l)
15510             enddo
15511           enddo
15512           if (j.lt.nres-1) then
15513             a22=-a22
15514             a32=-a32
15515             do l=1,3,2
15516               do k=1,3
15517                 agg(k,l)=-agg(k,l)
15518                 aggi(k,l)=-aggi(k,l)
15519                 aggi1(k,l)=-aggi1(k,l)
15520                 aggj(k,l)=-aggj(k,l)
15521                 aggj1(k,l)=-aggj1(k,l)
15522               enddo
15523             enddo
15524           else
15525             a22=-a22
15526             a23=-a23
15527             a32=-a32
15528             a33=-a33
15529             do l=1,4
15530               do k=1,3
15531                 agg(k,l)=-agg(k,l)
15532                 aggi(k,l)=-aggi(k,l)
15533                 aggi1(k,l)=-aggi1(k,l)
15534                 aggj(k,l)=-aggj(k,l)
15535                 aggj1(k,l)=-aggj1(k,l)
15536               enddo
15537             enddo
15538           endif
15539           ENDIF ! WCORR
15540           IF (wel_loc.gt.0.0d0) THEN
15541 ! Contribution to the local-electrostatic energy coming from the i-j pair
15542           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15543            +a33*muij(4)
15544 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15545 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15546           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15547                   'eelloc',i,j,eel_loc_ij
15548 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15549
15550           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15551 ! Partial derivatives in virtual-bond dihedral angles gamma
15552           if (i.gt.1) &
15553           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15554                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15555                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15556                  *sss_ele_cut
15557           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15558                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15559                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15560                  *sss_ele_cut
15561            xtemp(1)=xj
15562            xtemp(2)=yj
15563            xtemp(3)=zj
15564
15565 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15566           do l=1,3
15567             ggg(l)=(agg(l,1)*muij(1)+ &
15568                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15569             *sss_ele_cut &
15570              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15571
15572             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15573             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15574 !grad            ghalf=0.5d0*ggg(l)
15575 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15576 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15577           enddo
15578 !grad          do k=i+1,j2
15579 !grad            do l=1,3
15580 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15581 !grad            enddo
15582 !grad          enddo
15583 ! Remaining derivatives of eello
15584           do l=1,3
15585             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15586                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15587             *sss_ele_cut
15588
15589             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15590                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15591             *sss_ele_cut
15592
15593             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15594                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15595             *sss_ele_cut
15596
15597             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15598                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15599             *sss_ele_cut
15600
15601           enddo
15602           ENDIF
15603 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15604 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15605           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15606              .and. num_conti.le.maxconts) then
15607 !            write (iout,*) i,j," entered corr"
15608 !
15609 ! Calculate the contact function. The ith column of the array JCONT will
15610 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15611 ! greater than I). The arrays FACONT and GACONT will contain the values of
15612 ! the contact function and its derivative.
15613 !           r0ij=1.02D0*rpp(iteli,itelj)
15614 !           r0ij=1.11D0*rpp(iteli,itelj)
15615             r0ij=2.20D0*rpp(iteli,itelj)
15616 !           r0ij=1.55D0*rpp(iteli,itelj)
15617             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15618 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15619             if (fcont.gt.0.0D0) then
15620               num_conti=num_conti+1
15621               if (num_conti.gt.maxconts) then
15622 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15623                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15624                                ' will skip next contacts for this conf.',num_conti
15625               else
15626                 jcont_hb(num_conti,i)=j
15627 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15628 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15629                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15630                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15631 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15632 !  terms.
15633                 d_cont(num_conti,i)=rij
15634 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15635 !     --- Electrostatic-interaction matrix ---
15636                 a_chuj(1,1,num_conti,i)=a22
15637                 a_chuj(1,2,num_conti,i)=a23
15638                 a_chuj(2,1,num_conti,i)=a32
15639                 a_chuj(2,2,num_conti,i)=a33
15640 !     --- Gradient of rij
15641                 do kkk=1,3
15642                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15643                 enddo
15644                 kkll=0
15645                 do k=1,2
15646                   do l=1,2
15647                     kkll=kkll+1
15648                     do m=1,3
15649                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15650                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15651                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15652                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15653                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15654                     enddo
15655                   enddo
15656                 enddo
15657                 ENDIF
15658                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15659 ! Calculate contact energies
15660                 cosa4=4.0D0*cosa
15661                 wij=cosa-3.0D0*cosb*cosg
15662                 cosbg1=cosb+cosg
15663                 cosbg2=cosb-cosg
15664 !               fac3=dsqrt(-ael6i)/r0ij**3
15665                 fac3=dsqrt(-ael6i)*r3ij
15666 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15667                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15668                 if (ees0tmp.gt.0) then
15669                   ees0pij=dsqrt(ees0tmp)
15670                 else
15671                   ees0pij=0
15672                 endif
15673 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15674                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15675                 if (ees0tmp.gt.0) then
15676                   ees0mij=dsqrt(ees0tmp)
15677                 else
15678                   ees0mij=0
15679                 endif
15680 !               ees0mij=0.0D0
15681                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15682                      *sss_ele_cut
15683
15684                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15685                      *sss_ele_cut
15686
15687 ! Diagnostics. Comment out or remove after debugging!
15688 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15689 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15690 !               ees0m(num_conti,i)=0.0D0
15691 ! End diagnostics.
15692 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15693 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15694 ! Angular derivatives of the contact function
15695                 ees0pij1=fac3/ees0pij
15696                 ees0mij1=fac3/ees0mij
15697                 fac3p=-3.0D0*fac3*rrmij
15698                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15699                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15700 !               ees0mij1=0.0D0
15701                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15702                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15703                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15704                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15705                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15706                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15707                 ecosap=ecosa1+ecosa2
15708                 ecosbp=ecosb1+ecosb2
15709                 ecosgp=ecosg1+ecosg2
15710                 ecosam=ecosa1-ecosa2
15711                 ecosbm=ecosb1-ecosb2
15712                 ecosgm=ecosg1-ecosg2
15713 ! Diagnostics
15714 !               ecosap=ecosa1
15715 !               ecosbp=ecosb1
15716 !               ecosgp=ecosg1
15717 !               ecosam=0.0D0
15718 !               ecosbm=0.0D0
15719 !               ecosgm=0.0D0
15720 ! End diagnostics
15721                 facont_hb(num_conti,i)=fcont
15722                 fprimcont=fprimcont/rij
15723 !d              facont_hb(num_conti,i)=1.0D0
15724 ! Following line is for diagnostics.
15725 !d              fprimcont=0.0D0
15726                 do k=1,3
15727                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15728                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15729                 enddo
15730                 do k=1,3
15731                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15732                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15733                 enddo
15734 !                gggp(1)=gggp(1)+ees0pijp*xj
15735 !                gggp(2)=gggp(2)+ees0pijp*yj
15736 !                gggp(3)=gggp(3)+ees0pijp*zj
15737 !                gggm(1)=gggm(1)+ees0mijp*xj
15738 !                gggm(2)=gggm(2)+ees0mijp*yj
15739 !                gggm(3)=gggm(3)+ees0mijp*zj
15740                 gggp(1)=gggp(1)+ees0pijp*xj &
15741                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15742                 gggp(2)=gggp(2)+ees0pijp*yj &
15743                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15744                 gggp(3)=gggp(3)+ees0pijp*zj &
15745                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15746
15747                 gggm(1)=gggm(1)+ees0mijp*xj &
15748                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15749
15750                 gggm(2)=gggm(2)+ees0mijp*yj &
15751                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15752
15753                 gggm(3)=gggm(3)+ees0mijp*zj &
15754                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15755
15756 ! Derivatives due to the contact function
15757                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15758                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15759                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15760                 do k=1,3
15761 !
15762 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15763 !          following the change of gradient-summation algorithm.
15764 !
15765 !grad                  ghalfp=0.5D0*gggp(k)
15766 !grad                  ghalfm=0.5D0*gggm(k)
15767 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15768 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15769 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15770 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15771 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15772 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15773 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15774 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15775 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15776 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15777 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15778 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15779 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15780 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15781                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15782                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15783                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15784                      *sss_ele_cut
15785
15786                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15787                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15788                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15789                      *sss_ele_cut
15790
15791                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15792                      *sss_ele_cut
15793
15794                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15795                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15796                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15797                      *sss_ele_cut
15798
15799                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15800                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15801                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15802                      *sss_ele_cut
15803
15804                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15805                      *sss_ele_cut
15806
15807                 enddo
15808               ENDIF ! wcorr
15809               endif  ! num_conti.le.maxconts
15810             endif  ! fcont.gt.0
15811           endif    ! j.gt.i+1
15812           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15813             do k=1,4
15814               do l=1,3
15815                 ghalf=0.5d0*agg(l,k)
15816                 aggi(l,k)=aggi(l,k)+ghalf
15817                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15818                 aggj(l,k)=aggj(l,k)+ghalf
15819               enddo
15820             enddo
15821             if (j.eq.nres-1 .and. i.lt.j-2) then
15822               do k=1,4
15823                 do l=1,3
15824                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15825                 enddo
15826               enddo
15827             endif
15828           endif
15829  128      continue
15830 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15831       return
15832       end subroutine eelecij_scale
15833 !-----------------------------------------------------------------------------
15834       subroutine evdwpp_short(evdw1)
15835 !
15836 ! Compute Evdwpp
15837 !
15838 !      implicit real*8 (a-h,o-z)
15839 !      include 'DIMENSIONS'
15840 !      include 'COMMON.CONTROL'
15841 !      include 'COMMON.IOUNITS'
15842 !      include 'COMMON.GEO'
15843 !      include 'COMMON.VAR'
15844 !      include 'COMMON.LOCAL'
15845 !      include 'COMMON.CHAIN'
15846 !      include 'COMMON.DERIV'
15847 !      include 'COMMON.INTERACT'
15848 !      include 'COMMON.CONTACTS'
15849 !      include 'COMMON.TORSION'
15850 !      include 'COMMON.VECTORS'
15851 !      include 'COMMON.FFIELD'
15852       real(kind=8),dimension(3) :: ggg
15853 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15854 #ifdef MOMENT
15855       real(kind=8) :: scal_el=1.0d0
15856 #else
15857       real(kind=8) :: scal_el=0.5d0
15858 #endif
15859 !el local variables
15860       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15861       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15862       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15863                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15864                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15865       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15866                     dist_temp, dist_init,sss_grad
15867       integer xshift,yshift,zshift
15868
15869
15870       evdw1=0.0D0
15871 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15872 !     & " iatel_e_vdw",iatel_e_vdw
15873       call flush(iout)
15874       do i=iatel_s_vdw,iatel_e_vdw
15875         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15876         dxi=dc(1,i)
15877         dyi=dc(2,i)
15878         dzi=dc(3,i)
15879         dx_normi=dc_norm(1,i)
15880         dy_normi=dc_norm(2,i)
15881         dz_normi=dc_norm(3,i)
15882         xmedi=c(1,i)+0.5d0*dxi
15883         ymedi=c(2,i)+0.5d0*dyi
15884         zmedi=c(3,i)+0.5d0*dzi
15885           xmedi=dmod(xmedi,boxxsize)
15886           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15887           ymedi=dmod(ymedi,boxysize)
15888           if (ymedi.lt.0) ymedi=ymedi+boxysize
15889           zmedi=dmod(zmedi,boxzsize)
15890           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15891         num_conti=0
15892 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15893 !     &   ' ielend',ielend_vdw(i)
15894         call flush(iout)
15895         do j=ielstart_vdw(i),ielend_vdw(i)
15896           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15897 !el          ind=ind+1
15898           iteli=itel(i)
15899           itelj=itel(j)
15900           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15901           aaa=app(iteli,itelj)
15902           bbb=bpp(iteli,itelj)
15903           dxj=dc(1,j)
15904           dyj=dc(2,j)
15905           dzj=dc(3,j)
15906           dx_normj=dc_norm(1,j)
15907           dy_normj=dc_norm(2,j)
15908           dz_normj=dc_norm(3,j)
15909 !          xj=c(1,j)+0.5D0*dxj-xmedi
15910 !          yj=c(2,j)+0.5D0*dyj-ymedi
15911 !          zj=c(3,j)+0.5D0*dzj-zmedi
15912           xj=c(1,j)+0.5D0*dxj
15913           yj=c(2,j)+0.5D0*dyj
15914           zj=c(3,j)+0.5D0*dzj
15915           xj=mod(xj,boxxsize)
15916           if (xj.lt.0) xj=xj+boxxsize
15917           yj=mod(yj,boxysize)
15918           if (yj.lt.0) yj=yj+boxysize
15919           zj=mod(zj,boxzsize)
15920           if (zj.lt.0) zj=zj+boxzsize
15921       isubchap=0
15922       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15923       xj_safe=xj
15924       yj_safe=yj
15925       zj_safe=zj
15926       do xshift=-1,1
15927       do yshift=-1,1
15928       do zshift=-1,1
15929           xj=xj_safe+xshift*boxxsize
15930           yj=yj_safe+yshift*boxysize
15931           zj=zj_safe+zshift*boxzsize
15932           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15933           if(dist_temp.lt.dist_init) then
15934             dist_init=dist_temp
15935             xj_temp=xj
15936             yj_temp=yj
15937             zj_temp=zj
15938             isubchap=1
15939           endif
15940        enddo
15941        enddo
15942        enddo
15943        if (isubchap.eq.1) then
15944 !C          print *,i,j
15945           xj=xj_temp-xmedi
15946           yj=yj_temp-ymedi
15947           zj=zj_temp-zmedi
15948        else
15949           xj=xj_safe-xmedi
15950           yj=yj_safe-ymedi
15951           zj=zj_safe-zmedi
15952        endif
15953
15954           rij=xj*xj+yj*yj+zj*zj
15955           rrmij=1.0D0/rij
15956           rij=dsqrt(rij)
15957           sss=sscale(rij/rpp(iteli,itelj))
15958             sss_ele_cut=sscale_ele(rij)
15959             sss_ele_grad=sscagrad_ele(rij)
15960             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15961             if (sss_ele_cut.le.0.0) cycle
15962           if (sss.gt.0.0d0) then
15963             rmij=1.0D0/rij
15964             r3ij=rrmij*rmij
15965             r6ij=r3ij*r3ij
15966             ev1=aaa*r6ij*r6ij
15967 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15968             if (j.eq.i+2) ev1=scal_el*ev1
15969             ev2=bbb*r6ij
15970             evdwij=ev1+ev2
15971             if (energy_dec) then
15972               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15973             endif
15974             evdw1=evdw1+evdwij*sss*sss_ele_cut
15975 !
15976 ! Calculate contributions to the Cartesian gradient.
15977 !
15978             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15979 !            ggg(1)=facvdw*xj
15980 !            ggg(2)=facvdw*yj
15981 !            ggg(3)=facvdw*zj
15982           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15983           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15984           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15985           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15986           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15987           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15988
15989             do k=1,3
15990               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15991               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15992             enddo
15993           endif
15994         enddo ! j
15995       enddo   ! i
15996       return
15997       end subroutine evdwpp_short
15998 !-----------------------------------------------------------------------------
15999       subroutine escp_long(evdw2,evdw2_14)
16000 !
16001 ! This subroutine calculates the excluded-volume interaction energy between
16002 ! peptide-group centers and side chains and its gradient in virtual-bond and
16003 ! side-chain vectors.
16004 !
16005 !      implicit real*8 (a-h,o-z)
16006 !      include 'DIMENSIONS'
16007 !      include 'COMMON.GEO'
16008 !      include 'COMMON.VAR'
16009 !      include 'COMMON.LOCAL'
16010 !      include 'COMMON.CHAIN'
16011 !      include 'COMMON.DERIV'
16012 !      include 'COMMON.INTERACT'
16013 !      include 'COMMON.FFIELD'
16014 !      include 'COMMON.IOUNITS'
16015 !      include 'COMMON.CONTROL'
16016       real(kind=8),dimension(3) :: ggg
16017 !el local variables
16018       integer :: i,iint,j,k,iteli,itypj,subchap
16019       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16020       real(kind=8) :: evdw2,evdw2_14,evdwij
16021       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16022                     dist_temp, dist_init
16023
16024       evdw2=0.0D0
16025       evdw2_14=0.0d0
16026 !d    print '(a)','Enter ESCP'
16027 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16028       do i=iatscp_s,iatscp_e
16029         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16030         iteli=itel(i)
16031         xi=0.5D0*(c(1,i)+c(1,i+1))
16032         yi=0.5D0*(c(2,i)+c(2,i+1))
16033         zi=0.5D0*(c(3,i)+c(3,i+1))
16034           xi=mod(xi,boxxsize)
16035           if (xi.lt.0) xi=xi+boxxsize
16036           yi=mod(yi,boxysize)
16037           if (yi.lt.0) yi=yi+boxysize
16038           zi=mod(zi,boxzsize)
16039           if (zi.lt.0) zi=zi+boxzsize
16040
16041         do iint=1,nscp_gr(i)
16042
16043         do j=iscpstart(i,iint),iscpend(i,iint)
16044           itypj=itype(j,1)
16045           if (itypj.eq.ntyp1) cycle
16046 ! Uncomment following three lines for SC-p interactions
16047 !         xj=c(1,nres+j)-xi
16048 !         yj=c(2,nres+j)-yi
16049 !         zj=c(3,nres+j)-zi
16050 ! Uncomment following three lines for Ca-p interactions
16051           xj=c(1,j)
16052           yj=c(2,j)
16053           zj=c(3,j)
16054           xj=mod(xj,boxxsize)
16055           if (xj.lt.0) xj=xj+boxxsize
16056           yj=mod(yj,boxysize)
16057           if (yj.lt.0) yj=yj+boxysize
16058           zj=mod(zj,boxzsize)
16059           if (zj.lt.0) zj=zj+boxzsize
16060       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16061       xj_safe=xj
16062       yj_safe=yj
16063       zj_safe=zj
16064       subchap=0
16065       do xshift=-1,1
16066       do yshift=-1,1
16067       do zshift=-1,1
16068           xj=xj_safe+xshift*boxxsize
16069           yj=yj_safe+yshift*boxysize
16070           zj=zj_safe+zshift*boxzsize
16071           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16072           if(dist_temp.lt.dist_init) then
16073             dist_init=dist_temp
16074             xj_temp=xj
16075             yj_temp=yj
16076             zj_temp=zj
16077             subchap=1
16078           endif
16079        enddo
16080        enddo
16081        enddo
16082        if (subchap.eq.1) then
16083           xj=xj_temp-xi
16084           yj=yj_temp-yi
16085           zj=zj_temp-zi
16086        else
16087           xj=xj_safe-xi
16088           yj=yj_safe-yi
16089           zj=zj_safe-zi
16090        endif
16091           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16092
16093           rij=dsqrt(1.0d0/rrij)
16094             sss_ele_cut=sscale_ele(rij)
16095             sss_ele_grad=sscagrad_ele(rij)
16096 !            print *,sss_ele_cut,sss_ele_grad,&
16097 !            (rij),r_cut_ele,rlamb_ele
16098             if (sss_ele_cut.le.0.0) cycle
16099           sss=sscale((rij/rscp(itypj,iteli)))
16100           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16101           if (sss.lt.1.0d0) then
16102
16103             fac=rrij**expon2
16104             e1=fac*fac*aad(itypj,iteli)
16105             e2=fac*bad(itypj,iteli)
16106             if (iabs(j-i) .le. 2) then
16107               e1=scal14*e1
16108               e2=scal14*e2
16109               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16110             endif
16111             evdwij=e1+e2
16112             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16113             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16114                 'evdw2',i,j,sss,evdwij
16115 !
16116 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16117 !
16118             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16119             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16120             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16121             ggg(1)=xj*fac
16122             ggg(2)=yj*fac
16123             ggg(3)=zj*fac
16124 ! Uncomment following three lines for SC-p interactions
16125 !           do k=1,3
16126 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16127 !           enddo
16128 ! Uncomment following line for SC-p interactions
16129 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16130             do k=1,3
16131               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16132               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16133             enddo
16134           endif
16135         enddo
16136
16137         enddo ! iint
16138       enddo ! i
16139       do i=1,nct
16140         do j=1,3
16141           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16142           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16143           gradx_scp(j,i)=expon*gradx_scp(j,i)
16144         enddo
16145       enddo
16146 !******************************************************************************
16147 !
16148 !                              N O T E !!!
16149 !
16150 ! To save time the factor EXPON has been extracted from ALL components
16151 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16152 ! use!
16153 !
16154 !******************************************************************************
16155       return
16156       end subroutine escp_long
16157 !-----------------------------------------------------------------------------
16158       subroutine escp_short(evdw2,evdw2_14)
16159 !
16160 ! This subroutine calculates the excluded-volume interaction energy between
16161 ! peptide-group centers and side chains and its gradient in virtual-bond and
16162 ! side-chain vectors.
16163 !
16164 !      implicit real*8 (a-h,o-z)
16165 !      include 'DIMENSIONS'
16166 !      include 'COMMON.GEO'
16167 !      include 'COMMON.VAR'
16168 !      include 'COMMON.LOCAL'
16169 !      include 'COMMON.CHAIN'
16170 !      include 'COMMON.DERIV'
16171 !      include 'COMMON.INTERACT'
16172 !      include 'COMMON.FFIELD'
16173 !      include 'COMMON.IOUNITS'
16174 !      include 'COMMON.CONTROL'
16175       real(kind=8),dimension(3) :: ggg
16176 !el local variables
16177       integer :: i,iint,j,k,iteli,itypj,subchap
16178       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16179       real(kind=8) :: evdw2,evdw2_14,evdwij
16180       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16181                     dist_temp, dist_init
16182
16183       evdw2=0.0D0
16184       evdw2_14=0.0d0
16185 !d    print '(a)','Enter ESCP'
16186 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16187       do i=iatscp_s,iatscp_e
16188         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16189         iteli=itel(i)
16190         xi=0.5D0*(c(1,i)+c(1,i+1))
16191         yi=0.5D0*(c(2,i)+c(2,i+1))
16192         zi=0.5D0*(c(3,i)+c(3,i+1))
16193           xi=mod(xi,boxxsize)
16194           if (xi.lt.0) xi=xi+boxxsize
16195           yi=mod(yi,boxysize)
16196           if (yi.lt.0) yi=yi+boxysize
16197           zi=mod(zi,boxzsize)
16198           if (zi.lt.0) zi=zi+boxzsize
16199
16200         do iint=1,nscp_gr(i)
16201
16202         do j=iscpstart(i,iint),iscpend(i,iint)
16203           itypj=itype(j,1)
16204           if (itypj.eq.ntyp1) cycle
16205 ! Uncomment following three lines for SC-p interactions
16206 !         xj=c(1,nres+j)-xi
16207 !         yj=c(2,nres+j)-yi
16208 !         zj=c(3,nres+j)-zi
16209 ! Uncomment following three lines for Ca-p interactions
16210 !          xj=c(1,j)-xi
16211 !          yj=c(2,j)-yi
16212 !          zj=c(3,j)-zi
16213           xj=c(1,j)
16214           yj=c(2,j)
16215           zj=c(3,j)
16216           xj=mod(xj,boxxsize)
16217           if (xj.lt.0) xj=xj+boxxsize
16218           yj=mod(yj,boxysize)
16219           if (yj.lt.0) yj=yj+boxysize
16220           zj=mod(zj,boxzsize)
16221           if (zj.lt.0) zj=zj+boxzsize
16222       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16223       xj_safe=xj
16224       yj_safe=yj
16225       zj_safe=zj
16226       subchap=0
16227       do xshift=-1,1
16228       do yshift=-1,1
16229       do zshift=-1,1
16230           xj=xj_safe+xshift*boxxsize
16231           yj=yj_safe+yshift*boxysize
16232           zj=zj_safe+zshift*boxzsize
16233           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
16234           if(dist_temp.lt.dist_init) then
16235             dist_init=dist_temp
16236             xj_temp=xj
16237             yj_temp=yj
16238             zj_temp=zj
16239             subchap=1
16240           endif
16241        enddo
16242        enddo
16243        enddo
16244        if (subchap.eq.1) then
16245           xj=xj_temp-xi
16246           yj=yj_temp-yi
16247           zj=zj_temp-zi
16248        else
16249           xj=xj_safe-xi
16250           yj=yj_safe-yi
16251           zj=zj_safe-zi
16252        endif
16253
16254           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16255           rij=dsqrt(1.0d0/rrij)
16256             sss_ele_cut=sscale_ele(rij)
16257             sss_ele_grad=sscagrad_ele(rij)
16258 !            print *,sss_ele_cut,sss_ele_grad,&
16259 !            (rij),r_cut_ele,rlamb_ele
16260             if (sss_ele_cut.le.0.0) cycle
16261           sss=sscale(rij/rscp(itypj,iteli))
16262           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16263           if (sss.gt.0.0d0) then
16264
16265             fac=rrij**expon2
16266             e1=fac*fac*aad(itypj,iteli)
16267             e2=fac*bad(itypj,iteli)
16268             if (iabs(j-i) .le. 2) then
16269               e1=scal14*e1
16270               e2=scal14*e2
16271               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16272             endif
16273             evdwij=e1+e2
16274             evdw2=evdw2+evdwij*sss*sss_ele_cut
16275             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16276                 'evdw2',i,j,sss,evdwij
16277 !
16278 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16279 !
16280             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16281             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16282             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16283
16284             ggg(1)=xj*fac
16285             ggg(2)=yj*fac
16286             ggg(3)=zj*fac
16287 ! Uncomment following three lines for SC-p interactions
16288 !           do k=1,3
16289 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16290 !           enddo
16291 ! Uncomment following line for SC-p interactions
16292 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16293             do k=1,3
16294               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16295               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16296             enddo
16297           endif
16298         enddo
16299
16300         enddo ! iint
16301       enddo ! i
16302       do i=1,nct
16303         do j=1,3
16304           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16305           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16306           gradx_scp(j,i)=expon*gradx_scp(j,i)
16307         enddo
16308       enddo
16309 !******************************************************************************
16310 !
16311 !                              N O T E !!!
16312 !
16313 ! To save time the factor EXPON has been extracted from ALL components
16314 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16315 ! use!
16316 !
16317 !******************************************************************************
16318       return
16319       end subroutine escp_short
16320 !-----------------------------------------------------------------------------
16321 ! energy_p_new-sep_barrier.F
16322 !-----------------------------------------------------------------------------
16323       subroutine sc_grad_scale(scalfac)
16324 !      implicit real*8 (a-h,o-z)
16325       use calc_data
16326 !      include 'DIMENSIONS'
16327 !      include 'COMMON.CHAIN'
16328 !      include 'COMMON.DERIV'
16329 !      include 'COMMON.CALC'
16330 !      include 'COMMON.IOUNITS'
16331       real(kind=8),dimension(3) :: dcosom1,dcosom2
16332       real(kind=8) :: scalfac
16333 !el local variables
16334 !      integer :: i,j,k,l
16335
16336       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16337       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16338       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16339            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16340 ! diagnostics only
16341 !      eom1=0.0d0
16342 !      eom2=0.0d0
16343 !      eom12=evdwij*eps1_om12
16344 ! end diagnostics
16345 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16346 !     &  " sigder",sigder
16347 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16348 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16349       do k=1,3
16350         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16351         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16352       enddo
16353       do k=1,3
16354         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16355          *sss_ele_cut
16356       enddo
16357 !      write (iout,*) "gg",(gg(k),k=1,3)
16358       do k=1,3
16359         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16360                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16361                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16362                  *sss_ele_cut
16363         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16364                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16365                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16366          *sss_ele_cut
16367 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16368 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16369 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16370 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16371       enddo
16372 !
16373 ! Calculate the components of the gradient in DC and X
16374 !
16375       do l=1,3
16376         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16377         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16378       enddo
16379       return
16380       end subroutine sc_grad_scale
16381 !-----------------------------------------------------------------------------
16382 ! energy_split-sep.F
16383 !-----------------------------------------------------------------------------
16384       subroutine etotal_long(energia)
16385 !
16386 ! Compute the long-range slow-varying contributions to the energy
16387 !
16388 !      implicit real*8 (a-h,o-z)
16389 !      include 'DIMENSIONS'
16390       use MD_data, only: totT,usampl,eq_time
16391 #ifndef ISNAN
16392       external proc_proc
16393 #ifdef WINPGI
16394 !MS$ATTRIBUTES C ::  proc_proc
16395 #endif
16396 #endif
16397 #ifdef MPI
16398       include "mpif.h"
16399       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16400 #endif
16401 !      include 'COMMON.SETUP'
16402 !      include 'COMMON.IOUNITS'
16403 !      include 'COMMON.FFIELD'
16404 !      include 'COMMON.DERIV'
16405 !      include 'COMMON.INTERACT'
16406 !      include 'COMMON.SBRIDGE'
16407 !      include 'COMMON.CHAIN'
16408 !      include 'COMMON.VAR'
16409 !      include 'COMMON.LOCAL'
16410 !      include 'COMMON.MD'
16411       real(kind=8),dimension(0:n_ene) :: energia
16412 !el local variables
16413       integer :: i,n_corr,n_corr1,ierror,ierr
16414       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16415                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16416                   ecorr,ecorr5,ecorr6,eturn6,time00
16417 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16418 !elwrite(iout,*)"in etotal long"
16419
16420       if (modecalc.eq.12.or.modecalc.eq.14) then
16421 #ifdef MPI
16422 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16423 #else
16424         call int_from_cart1(.false.)
16425 #endif
16426       endif
16427 !elwrite(iout,*)"in etotal long"
16428
16429 #ifdef MPI
16430 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16431 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16432       call flush(iout)
16433       if (nfgtasks.gt.1) then
16434         time00=MPI_Wtime()
16435 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16436         if (fg_rank.eq.0) then
16437           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16438 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16439 !          call flush(iout)
16440 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16441 ! FG slaves as WEIGHTS array.
16442           weights_(1)=wsc
16443           weights_(2)=wscp
16444           weights_(3)=welec
16445           weights_(4)=wcorr
16446           weights_(5)=wcorr5
16447           weights_(6)=wcorr6
16448           weights_(7)=wel_loc
16449           weights_(8)=wturn3
16450           weights_(9)=wturn4
16451           weights_(10)=wturn6
16452           weights_(11)=wang
16453           weights_(12)=wscloc
16454           weights_(13)=wtor
16455           weights_(14)=wtor_d
16456           weights_(15)=wstrain
16457           weights_(16)=wvdwpp
16458           weights_(17)=wbond
16459           weights_(18)=scal14
16460           weights_(21)=wsccor
16461 ! FG Master broadcasts the WEIGHTS_ array
16462           call MPI_Bcast(weights_(1),n_ene,&
16463               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16464         else
16465 ! FG slaves receive the WEIGHTS array
16466           call MPI_Bcast(weights(1),n_ene,&
16467               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16468           wsc=weights(1)
16469           wscp=weights(2)
16470           welec=weights(3)
16471           wcorr=weights(4)
16472           wcorr5=weights(5)
16473           wcorr6=weights(6)
16474           wel_loc=weights(7)
16475           wturn3=weights(8)
16476           wturn4=weights(9)
16477           wturn6=weights(10)
16478           wang=weights(11)
16479           wscloc=weights(12)
16480           wtor=weights(13)
16481           wtor_d=weights(14)
16482           wstrain=weights(15)
16483           wvdwpp=weights(16)
16484           wbond=weights(17)
16485           scal14=weights(18)
16486           wsccor=weights(21)
16487         endif
16488         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16489           king,FG_COMM,IERR)
16490          time_Bcast=time_Bcast+MPI_Wtime()-time00
16491          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16492 !        call chainbuild_cart
16493 !        call int_from_cart1(.false.)
16494       endif
16495 !      write (iout,*) 'Processor',myrank,
16496 !     &  ' calling etotal_short ipot=',ipot
16497 !      call flush(iout)
16498 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16499 #endif
16500 !d    print *,'nnt=',nnt,' nct=',nct
16501 !
16502 !elwrite(iout,*)"in etotal long"
16503 ! Compute the side-chain and electrostatic interaction energy
16504 !
16505       goto (101,102,103,104,105,106) ipot
16506 ! Lennard-Jones potential.
16507   101 call elj_long(evdw)
16508 !d    print '(a)','Exit ELJ'
16509       goto 107
16510 ! Lennard-Jones-Kihara potential (shifted).
16511   102 call eljk_long(evdw)
16512       goto 107
16513 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16514   103 call ebp_long(evdw)
16515       goto 107
16516 ! Gay-Berne potential (shifted LJ, angular dependence).
16517   104 call egb_long(evdw)
16518       goto 107
16519 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16520   105 call egbv_long(evdw)
16521       goto 107
16522 ! Soft-sphere potential
16523   106 call e_softsphere(evdw)
16524 !
16525 ! Calculate electrostatic (H-bonding) energy of the main chain.
16526 !
16527   107 continue
16528       call vec_and_deriv
16529       if (ipot.lt.6) then
16530 #ifdef SPLITELE
16531          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16532              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16533              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16534              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16535 #else
16536          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16537              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16538              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16539              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16540 #endif
16541            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16542          else
16543             ees=0
16544             evdw1=0
16545             eel_loc=0
16546             eello_turn3=0
16547             eello_turn4=0
16548          endif
16549       else
16550 !        write (iout,*) "Soft-spheer ELEC potential"
16551         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16552          eello_turn4)
16553       endif
16554 !
16555 ! Calculate excluded-volume interaction energy between peptide groups
16556 ! and side chains.
16557 !
16558       if (ipot.lt.6) then
16559        if(wscp.gt.0d0) then
16560         call escp_long(evdw2,evdw2_14)
16561        else
16562         evdw2=0
16563         evdw2_14=0
16564        endif
16565       else
16566         call escp_soft_sphere(evdw2,evdw2_14)
16567       endif
16568 !
16569 ! 12/1/95 Multi-body terms
16570 !
16571       n_corr=0
16572       n_corr1=0
16573       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16574           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16575          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16576 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16577 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16578       else
16579          ecorr=0.0d0
16580          ecorr5=0.0d0
16581          ecorr6=0.0d0
16582          eturn6=0.0d0
16583       endif
16584       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16585          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16586       endif
16587 !
16588 ! If performing constraint dynamics, call the constraint energy
16589 !  after the equilibration time
16590       if(usampl.and.totT.gt.eq_time) then
16591          call EconstrQ
16592          call Econstr_back
16593       else
16594          Uconst=0.0d0
16595          Uconst_back=0.0d0
16596       endif
16597 !
16598 ! Sum the energies
16599 !
16600       do i=1,n_ene
16601         energia(i)=0.0d0
16602       enddo
16603       energia(1)=evdw
16604 #ifdef SCP14
16605       energia(2)=evdw2-evdw2_14
16606       energia(18)=evdw2_14
16607 #else
16608       energia(2)=evdw2
16609       energia(18)=0.0d0
16610 #endif
16611 #ifdef SPLITELE
16612       energia(3)=ees
16613       energia(16)=evdw1
16614 #else
16615       energia(3)=ees+evdw1
16616       energia(16)=0.0d0
16617 #endif
16618       energia(4)=ecorr
16619       energia(5)=ecorr5
16620       energia(6)=ecorr6
16621       energia(7)=eel_loc
16622       energia(8)=eello_turn3
16623       energia(9)=eello_turn4
16624       energia(10)=eturn6
16625       energia(20)=Uconst+Uconst_back
16626       call sum_energy(energia,.true.)
16627 !      write (iout,*) "Exit ETOTAL_LONG"
16628       call flush(iout)
16629       return
16630       end subroutine etotal_long
16631 !-----------------------------------------------------------------------------
16632       subroutine etotal_short(energia)
16633 !
16634 ! Compute the short-range fast-varying contributions to the energy
16635 !
16636 !      implicit real*8 (a-h,o-z)
16637 !      include 'DIMENSIONS'
16638 #ifndef ISNAN
16639       external proc_proc
16640 #ifdef WINPGI
16641 !MS$ATTRIBUTES C ::  proc_proc
16642 #endif
16643 #endif
16644 #ifdef MPI
16645       include "mpif.h"
16646       integer :: ierror,ierr
16647       real(kind=8),dimension(n_ene) :: weights_
16648       real(kind=8) :: time00
16649 #endif
16650 !      include 'COMMON.SETUP'
16651 !      include 'COMMON.IOUNITS'
16652 !      include 'COMMON.FFIELD'
16653 !      include 'COMMON.DERIV'
16654 !      include 'COMMON.INTERACT'
16655 !      include 'COMMON.SBRIDGE'
16656 !      include 'COMMON.CHAIN'
16657 !      include 'COMMON.VAR'
16658 !      include 'COMMON.LOCAL'
16659       real(kind=8),dimension(0:n_ene) :: energia
16660 !el local variables
16661       integer :: i,nres6
16662       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16663       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16664       nres6=6*nres
16665
16666 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16667 !      call flush(iout)
16668       if (modecalc.eq.12.or.modecalc.eq.14) then
16669 #ifdef MPI
16670         if (fg_rank.eq.0) call int_from_cart1(.false.)
16671 #else
16672         call int_from_cart1(.false.)
16673 #endif
16674       endif
16675 #ifdef MPI
16676 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16677 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16678 !      call flush(iout)
16679       if (nfgtasks.gt.1) then
16680         time00=MPI_Wtime()
16681 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16682         if (fg_rank.eq.0) then
16683           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16684 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16685 !          call flush(iout)
16686 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16687 ! FG slaves as WEIGHTS array.
16688           weights_(1)=wsc
16689           weights_(2)=wscp
16690           weights_(3)=welec
16691           weights_(4)=wcorr
16692           weights_(5)=wcorr5
16693           weights_(6)=wcorr6
16694           weights_(7)=wel_loc
16695           weights_(8)=wturn3
16696           weights_(9)=wturn4
16697           weights_(10)=wturn6
16698           weights_(11)=wang
16699           weights_(12)=wscloc
16700           weights_(13)=wtor
16701           weights_(14)=wtor_d
16702           weights_(15)=wstrain
16703           weights_(16)=wvdwpp
16704           weights_(17)=wbond
16705           weights_(18)=scal14
16706           weights_(21)=wsccor
16707 ! FG Master broadcasts the WEIGHTS_ array
16708           call MPI_Bcast(weights_(1),n_ene,&
16709               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16710         else
16711 ! FG slaves receive the WEIGHTS array
16712           call MPI_Bcast(weights(1),n_ene,&
16713               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16714           wsc=weights(1)
16715           wscp=weights(2)
16716           welec=weights(3)
16717           wcorr=weights(4)
16718           wcorr5=weights(5)
16719           wcorr6=weights(6)
16720           wel_loc=weights(7)
16721           wturn3=weights(8)
16722           wturn4=weights(9)
16723           wturn6=weights(10)
16724           wang=weights(11)
16725           wscloc=weights(12)
16726           wtor=weights(13)
16727           wtor_d=weights(14)
16728           wstrain=weights(15)
16729           wvdwpp=weights(16)
16730           wbond=weights(17)
16731           scal14=weights(18)
16732           wsccor=weights(21)
16733         endif
16734 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16735         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16736           king,FG_COMM,IERR)
16737 !        write (iout,*) "Processor",myrank," BROADCAST c"
16738         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16739           king,FG_COMM,IERR)
16740 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16741         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16742           king,FG_COMM,IERR)
16743 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16744         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16745           king,FG_COMM,IERR)
16746 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16747         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16748           king,FG_COMM,IERR)
16749 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16750         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16751           king,FG_COMM,IERR)
16752 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16753         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16754           king,FG_COMM,IERR)
16755 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16756         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16757           king,FG_COMM,IERR)
16758 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16759         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16760           king,FG_COMM,IERR)
16761          time_Bcast=time_Bcast+MPI_Wtime()-time00
16762 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16763       endif
16764 !      write (iout,*) 'Processor',myrank,
16765 !     &  ' calling etotal_short ipot=',ipot
16766 !      call flush(iout)
16767 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16768 #endif
16769 !      call int_from_cart1(.false.)
16770 !
16771 ! Compute the side-chain and electrostatic interaction energy
16772 !
16773       goto (101,102,103,104,105,106) ipot
16774 ! Lennard-Jones potential.
16775   101 call elj_short(evdw)
16776 !d    print '(a)','Exit ELJ'
16777       goto 107
16778 ! Lennard-Jones-Kihara potential (shifted).
16779   102 call eljk_short(evdw)
16780       goto 107
16781 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16782   103 call ebp_short(evdw)
16783       goto 107
16784 ! Gay-Berne potential (shifted LJ, angular dependence).
16785   104 call egb_short(evdw)
16786       goto 107
16787 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16788   105 call egbv_short(evdw)
16789       goto 107
16790 ! Soft-sphere potential - already dealt with in the long-range part
16791   106 evdw=0.0d0
16792 !  106 call e_softsphere_short(evdw)
16793 !
16794 ! Calculate electrostatic (H-bonding) energy of the main chain.
16795 !
16796   107 continue
16797 !
16798 ! Calculate the short-range part of Evdwpp
16799 !
16800       call evdwpp_short(evdw1)
16801 !
16802 ! Calculate the short-range part of ESCp
16803 !
16804       if (ipot.lt.6) then
16805         call escp_short(evdw2,evdw2_14)
16806       endif
16807 !
16808 ! Calculate the bond-stretching energy
16809 !
16810       call ebond(estr)
16811 !
16812 ! Calculate the disulfide-bridge and other energy and the contributions
16813 ! from other distance constraints.
16814       call edis(ehpb)
16815 !
16816 ! Calculate the virtual-bond-angle energy.
16817 !
16818 ! Calculate the SC local energy.
16819 !
16820       call vec_and_deriv
16821       call esc(escloc)
16822 !
16823       if (wang.gt.0d0) then
16824        if (tor_mode.eq.0) then
16825          call ebend(ebe)
16826        else
16827 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16828 !C energy function
16829          call ebend_kcc(ebe)
16830        endif
16831       else
16832         ebe=0.0d0
16833       endif
16834       ethetacnstr=0.0d0
16835       if (with_theta_constr) call etheta_constr(ethetacnstr)
16836
16837 !       write(iout,*) "in etotal afer ebe",ipot
16838
16839 !      print *,"Processor",myrank," computed UB"
16840 !
16841 ! Calculate the SC local energy.
16842 !
16843       call esc(escloc)
16844 !elwrite(iout,*) "in etotal afer esc",ipot
16845 !      print *,"Processor",myrank," computed USC"
16846 !
16847 ! Calculate the virtual-bond torsional energy.
16848 !
16849 !d    print *,'nterm=',nterm
16850 !      if (wtor.gt.0) then
16851 !       call etor(etors,edihcnstr)
16852 !      else
16853 !       etors=0
16854 !       edihcnstr=0
16855 !      endif
16856       if (wtor.gt.0.0d0) then
16857          if (tor_mode.eq.0) then
16858            call etor(etors)
16859          else
16860 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16861 !C energy function
16862            call etor_kcc(etors)
16863          endif
16864       else
16865         etors=0.0d0
16866       endif
16867       edihcnstr=0.0d0
16868       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16869
16870 ! Calculate the virtual-bond torsional energy.
16871 !
16872 !
16873 ! 6/23/01 Calculate double-torsional energy
16874 !
16875       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16876       call etor_d(etors_d)
16877       endif
16878 !
16879 ! 21/5/07 Calculate local sicdechain correlation energy
16880 !
16881       if (wsccor.gt.0.0d0) then
16882         call eback_sc_corr(esccor)
16883       else
16884         esccor=0.0d0
16885       endif
16886 !
16887 ! Put energy components into an array
16888 !
16889       do i=1,n_ene
16890         energia(i)=0.0d0
16891       enddo
16892       energia(1)=evdw
16893 #ifdef SCP14
16894       energia(2)=evdw2-evdw2_14
16895       energia(18)=evdw2_14
16896 #else
16897       energia(2)=evdw2
16898       energia(18)=0.0d0
16899 #endif
16900 #ifdef SPLITELE
16901       energia(16)=evdw1
16902 #else
16903       energia(3)=evdw1
16904 #endif
16905       energia(11)=ebe
16906       energia(12)=escloc
16907       energia(13)=etors
16908       energia(14)=etors_d
16909       energia(15)=ehpb
16910       energia(17)=estr
16911       energia(19)=edihcnstr
16912       energia(21)=esccor
16913 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16914       call flush(iout)
16915       call sum_energy(energia,.true.)
16916 !      write (iout,*) "Exit ETOTAL_SHORT"
16917       call flush(iout)
16918       return
16919       end subroutine etotal_short
16920 !-----------------------------------------------------------------------------
16921 ! gnmr1.f
16922 !-----------------------------------------------------------------------------
16923       real(kind=8) function gnmr1(y,ymin,ymax)
16924 !      implicit none
16925       real(kind=8) :: y,ymin,ymax
16926       real(kind=8) :: wykl=4.0d0
16927       if (y.lt.ymin) then
16928         gnmr1=(ymin-y)**wykl/wykl
16929       else if (y.gt.ymax) then
16930         gnmr1=(y-ymax)**wykl/wykl
16931       else
16932         gnmr1=0.0d0
16933       endif
16934       return
16935       end function gnmr1
16936 !-----------------------------------------------------------------------------
16937       real(kind=8) function gnmr1prim(y,ymin,ymax)
16938 !      implicit none
16939       real(kind=8) :: y,ymin,ymax
16940       real(kind=8) :: wykl=4.0d0
16941       if (y.lt.ymin) then
16942         gnmr1prim=-(ymin-y)**(wykl-1)
16943       else if (y.gt.ymax) then
16944         gnmr1prim=(y-ymax)**(wykl-1)
16945       else
16946         gnmr1prim=0.0d0
16947       endif
16948       return
16949       end function gnmr1prim
16950 !----------------------------------------------------------------------------
16951       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16952       real(kind=8) y,ymin,ymax,sigma
16953       real(kind=8) wykl /4.0d0/
16954       if (y.lt.ymin) then
16955         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16956       else if (y.gt.ymax) then
16957         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16958       else
16959         rlornmr1=0.0d0
16960       endif
16961       return
16962       end function rlornmr1
16963 !------------------------------------------------------------------------------
16964       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16965       real(kind=8) y,ymin,ymax,sigma
16966       real(kind=8) wykl /4.0d0/
16967       if (y.lt.ymin) then
16968         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16969         ((ymin-y)**wykl+sigma**wykl)**2
16970       else if (y.gt.ymax) then
16971         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16972         ((y-ymax)**wykl+sigma**wykl)**2
16973       else
16974         rlornmr1prim=0.0d0
16975       endif
16976       return
16977       end function rlornmr1prim
16978
16979       real(kind=8) function harmonic(y,ymax)
16980 !      implicit none
16981       real(kind=8) :: y,ymax
16982       real(kind=8) :: wykl=2.0d0
16983       harmonic=(y-ymax)**wykl
16984       return
16985       end function harmonic
16986 !-----------------------------------------------------------------------------
16987       real(kind=8) function harmonicprim(y,ymax)
16988       real(kind=8) :: y,ymin,ymax
16989       real(kind=8) :: wykl=2.0d0
16990       harmonicprim=(y-ymax)*wykl
16991       return
16992       end function harmonicprim
16993 !-----------------------------------------------------------------------------
16994 ! gradient_p.F
16995 !-----------------------------------------------------------------------------
16996       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16997
16998       use io_base, only:intout,briefout
16999 !      implicit real*8 (a-h,o-z)
17000 !      include 'DIMENSIONS'
17001 !      include 'COMMON.CHAIN'
17002 !      include 'COMMON.DERIV'
17003 !      include 'COMMON.VAR'
17004 !      include 'COMMON.INTERACT'
17005 !      include 'COMMON.FFIELD'
17006 !      include 'COMMON.MD'
17007 !      include 'COMMON.IOUNITS'
17008       real(kind=8),external :: ufparm
17009       integer :: uiparm(1)
17010       real(kind=8) :: urparm(1)
17011       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17012       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17013       integer :: n,nf,ind,ind1,i,k,j
17014 !
17015 ! This subroutine calculates total internal coordinate gradient.
17016 ! Depending on the number of function evaluations, either whole energy
17017 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17018 ! internal coordinates are reevaluated or only the cartesian-in-internal
17019 ! coordinate derivatives are evaluated. The subroutine was designed to work
17020 ! with SUMSL.
17021 !
17022 !
17023       icg=mod(nf,2)+1
17024
17025 !d      print *,'grad',nf,icg
17026       if (nf-nfl+1) 20,30,40
17027    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17028 !    write (iout,*) 'grad 20'
17029       if (nf.eq.0) return
17030       goto 40
17031    30 call var_to_geom(n,x)
17032       call chainbuild
17033 !    write (iout,*) 'grad 30'
17034 !
17035 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17036 !
17037    40 call cartder
17038 !     write (iout,*) 'grad 40'
17039 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17040 !
17041 ! Convert the Cartesian gradient into internal-coordinate gradient.
17042 !
17043       ind=0
17044       ind1=0
17045       do i=1,nres-2
17046       gthetai=0.0D0
17047       gphii=0.0D0
17048       do j=i+1,nres-1
17049           ind=ind+1
17050 !         ind=indmat(i,j)
17051 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17052         do k=1,3
17053             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17054           enddo
17055         do k=1,3
17056           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17057           enddo
17058         enddo
17059       do j=i+1,nres-1
17060           ind1=ind1+1
17061 !         ind1=indmat(i,j)
17062 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17063         do k=1,3
17064           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17065           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17066           enddo
17067         enddo
17068       if (i.gt.1) g(i-1)=gphii
17069       if (n.gt.nphi) g(nphi+i)=gthetai
17070       enddo
17071       if (n.le.nphi+ntheta) goto 10
17072       do i=2,nres-1
17073       if (itype(i,1).ne.10) then
17074           galphai=0.0D0
17075         gomegai=0.0D0
17076         do k=1,3
17077           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17078           enddo
17079         do k=1,3
17080           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17081           enddo
17082           g(ialph(i,1))=galphai
17083         g(ialph(i,1)+nside)=gomegai
17084         endif
17085       enddo
17086 !
17087 ! Add the components corresponding to local energy terms.
17088 !
17089    10 continue
17090       do i=1,nvar
17091 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17092         g(i)=g(i)+gloc(i,icg)
17093       enddo
17094 ! Uncomment following three lines for diagnostics.
17095 !d    call intout
17096 !elwrite(iout,*) "in gradient after calling intout"
17097 !d    call briefout(0,0.0d0)
17098 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17099       return
17100       end subroutine gradient
17101 !-----------------------------------------------------------------------------
17102       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17103
17104       use comm_chu
17105 !      implicit real*8 (a-h,o-z)
17106 !      include 'DIMENSIONS'
17107 !      include 'COMMON.DERIV'
17108 !      include 'COMMON.IOUNITS'
17109 !      include 'COMMON.GEO'
17110       integer :: n,nf
17111 !el      integer :: jjj
17112 !el      common /chuju/ jjj
17113       real(kind=8) :: energia(0:n_ene)
17114       integer :: uiparm(1)
17115       real(kind=8) :: urparm(1)
17116       real(kind=8) :: f
17117       real(kind=8),external :: ufparm
17118       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17119 !     if (jjj.gt.0) then
17120 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17121 !     endif
17122       nfl=nf
17123       icg=mod(nf,2)+1
17124 !d      print *,'func',nf,nfl,icg
17125       call var_to_geom(n,x)
17126       call zerograd
17127       call chainbuild
17128 !d    write (iout,*) 'ETOTAL called from FUNC'
17129       call etotal(energia)
17130       call sum_gradient
17131       f=energia(0)
17132 !     if (jjj.gt.0) then
17133 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17134 !       write (iout,*) 'f=',etot
17135 !       jjj=0
17136 !     endif
17137       return
17138       end subroutine func
17139 !-----------------------------------------------------------------------------
17140       subroutine cartgrad
17141 !      implicit real*8 (a-h,o-z)
17142 !      include 'DIMENSIONS'
17143       use energy_data
17144       use MD_data, only: totT,usampl,eq_time
17145 #ifdef MPI
17146       include 'mpif.h'
17147 #endif
17148 !      include 'COMMON.CHAIN'
17149 !      include 'COMMON.DERIV'
17150 !      include 'COMMON.VAR'
17151 !      include 'COMMON.INTERACT'
17152 !      include 'COMMON.FFIELD'
17153 !      include 'COMMON.MD'
17154 !      include 'COMMON.IOUNITS'
17155 !      include 'COMMON.TIME1'
17156 !
17157       integer :: i,j
17158
17159 ! This subrouting calculates total Cartesian coordinate gradient.
17160 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17161 !
17162 !#define DEBUG
17163 #ifdef TIMING
17164       time00=MPI_Wtime()
17165 #endif
17166       icg=1
17167       call sum_gradient
17168 #ifdef TIMING
17169 #endif
17170 !#define DEBUG
17171 !el      write (iout,*) "After sum_gradient"
17172 #ifdef DEBUG
17173       write (iout,*) "After sum_gradient"
17174       do i=1,nres-1
17175         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17176         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17177       enddo
17178 #endif
17179 !#undef DEBUG
17180 ! If performing constraint dynamics, add the gradients of the constraint energy
17181       if(usampl.and.totT.gt.eq_time) then
17182          do i=1,nct
17183            do j=1,3
17184              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17185              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17186            enddo
17187          enddo
17188          do i=1,nres-3
17189            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17190          enddo
17191          do i=1,nres-2
17192            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17193          enddo
17194       endif
17195 !elwrite (iout,*) "After sum_gradient"
17196 #ifdef TIMING
17197       time01=MPI_Wtime()
17198 #endif
17199       call intcartderiv
17200 !elwrite (iout,*) "After sum_gradient"
17201 #ifdef TIMING
17202       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17203 #endif
17204 !     call checkintcartgrad
17205 !     write(iout,*) 'calling int_to_cart'
17206 !#define DEBUG
17207 #ifdef DEBUG
17208       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17209 #endif
17210       do i=0,nct
17211         do j=1,3
17212           gcart(j,i)=gradc(j,i,icg)
17213           gxcart(j,i)=gradx(j,i,icg)
17214 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17215         enddo
17216 #ifdef DEBUG
17217         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17218           (gxcart(j,i),j=1,3),gloc(i,icg)
17219 #endif
17220       enddo
17221 #ifdef TIMING
17222       time01=MPI_Wtime()
17223 #endif
17224 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17225       call int_to_cart
17226 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17227
17228 #ifdef TIMING
17229             time_inttocart=time_inttocart+MPI_Wtime()-time01
17230 #endif
17231 #ifdef DEBUG
17232             write (iout,*) "gcart and gxcart after int_to_cart"
17233             do i=0,nres-1
17234             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17235                 (gxcart(j,i),j=1,3)
17236             enddo
17237 #endif
17238 !#undef DEBUG
17239 #ifdef CARGRAD
17240 #ifdef DEBUG
17241             write (iout,*) "CARGRAD"
17242 #endif
17243             do i=nres,0,-1
17244             do j=1,3
17245               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17246       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17247             enddo
17248       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17249       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17250             enddo
17251       ! Correction: dummy residues
17252             if (nnt.gt.1) then
17253               do j=1,3
17254       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17255                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17256               enddo
17257             endif
17258             if (nct.lt.nres) then
17259               do j=1,3
17260       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17261                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17262               enddo
17263             endif
17264 #endif
17265 #ifdef TIMING
17266             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17267 #endif
17268 !#undef DEBUG
17269             return
17270             end subroutine cartgrad
17271       !-----------------------------------------------------------------------------
17272             subroutine zerograd
17273       !      implicit real*8 (a-h,o-z)
17274       !      include 'DIMENSIONS'
17275       !      include 'COMMON.DERIV'
17276       !      include 'COMMON.CHAIN'
17277       !      include 'COMMON.VAR'
17278       !      include 'COMMON.MD'
17279       !      include 'COMMON.SCCOR'
17280       !
17281       !el local variables
17282             integer :: i,j,intertyp,k
17283       ! Initialize Cartesian-coordinate gradient
17284       !
17285       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17286       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17287
17288       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17289       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17290       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17291       !      allocate(gradcorr_long(3,nres))
17292       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17293       !      allocate(gcorr6_turn_long(3,nres))
17294       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17295
17296       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17297
17298       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17299       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17300
17301       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17302       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17303
17304       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17305       !      allocate(gscloc(3,nres)) !(3,maxres)
17306       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17307
17308
17309
17310       !      common /deriv_scloc/
17311       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17312       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17313       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17314       !      common /mpgrad/
17315       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17316
17317
17318
17319       !          gradc(j,i,icg)=0.0d0
17320       !          gradx(j,i,icg)=0.0d0
17321
17322       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17323       !elwrite(iout,*) "icg",icg
17324             do i=-1,nres
17325             do j=1,3
17326               gvdwx(j,i)=0.0D0
17327               gradx_scp(j,i)=0.0D0
17328               gvdwc(j,i)=0.0D0
17329               gvdwc_scp(j,i)=0.0D0
17330               gvdwc_scpp(j,i)=0.0d0
17331               gelc(j,i)=0.0D0
17332               gelc_long(j,i)=0.0D0
17333               gradb(j,i)=0.0d0
17334               gradbx(j,i)=0.0d0
17335               gvdwpp(j,i)=0.0d0
17336               gel_loc(j,i)=0.0d0
17337               gel_loc_long(j,i)=0.0d0
17338               ghpbc(j,i)=0.0D0
17339               ghpbx(j,i)=0.0D0
17340               gcorr3_turn(j,i)=0.0d0
17341               gcorr4_turn(j,i)=0.0d0
17342               gradcorr(j,i)=0.0d0
17343               gradcorr_long(j,i)=0.0d0
17344               gradcorr5_long(j,i)=0.0d0
17345               gradcorr6_long(j,i)=0.0d0
17346               gcorr6_turn_long(j,i)=0.0d0
17347               gradcorr5(j,i)=0.0d0
17348               gradcorr6(j,i)=0.0d0
17349               gcorr6_turn(j,i)=0.0d0
17350               gsccorc(j,i)=0.0d0
17351               gsccorx(j,i)=0.0d0
17352               gradc(j,i,icg)=0.0d0
17353               gradx(j,i,icg)=0.0d0
17354               gscloc(j,i)=0.0d0
17355               gsclocx(j,i)=0.0d0
17356               gliptran(j,i)=0.0d0
17357               gliptranx(j,i)=0.0d0
17358               gliptranc(j,i)=0.0d0
17359               gshieldx(j,i)=0.0d0
17360               gshieldc(j,i)=0.0d0
17361               gshieldc_loc(j,i)=0.0d0
17362               gshieldx_ec(j,i)=0.0d0
17363               gshieldc_ec(j,i)=0.0d0
17364               gshieldc_loc_ec(j,i)=0.0d0
17365               gshieldx_t3(j,i)=0.0d0
17366               gshieldc_t3(j,i)=0.0d0
17367               gshieldc_loc_t3(j,i)=0.0d0
17368               gshieldx_t4(j,i)=0.0d0
17369               gshieldc_t4(j,i)=0.0d0
17370               gshieldc_loc_t4(j,i)=0.0d0
17371               gshieldx_ll(j,i)=0.0d0
17372               gshieldc_ll(j,i)=0.0d0
17373               gshieldc_loc_ll(j,i)=0.0d0
17374               gg_tube(j,i)=0.0d0
17375               gg_tube_sc(j,i)=0.0d0
17376               gradafm(j,i)=0.0d0
17377               gradb_nucl(j,i)=0.0d0
17378               gradbx_nucl(j,i)=0.0d0
17379               gvdwpp_nucl(j,i)=0.0d0
17380               gvdwpp(j,i)=0.0d0
17381               gelpp(j,i)=0.0d0
17382               gvdwpsb(j,i)=0.0d0
17383               gvdwpsb1(j,i)=0.0d0
17384               gvdwsbc(j,i)=0.0d0
17385               gvdwsbx(j,i)=0.0d0
17386               gelsbc(j,i)=0.0d0
17387               gradcorr_nucl(j,i)=0.0d0
17388               gradcorr3_nucl(j,i)=0.0d0
17389               gradxorr_nucl(j,i)=0.0d0
17390               gradxorr3_nucl(j,i)=0.0d0
17391               gelsbx(j,i)=0.0d0
17392               gsbloc(j,i)=0.0d0
17393               gsblocx(j,i)=0.0d0
17394               gradpepcat(j,i)=0.0d0
17395               gradpepcatx(j,i)=0.0d0
17396               gradcatcat(j,i)=0.0d0
17397               gvdwx_scbase(j,i)=0.0d0
17398               gvdwc_scbase(j,i)=0.0d0
17399               gvdwx_pepbase(j,i)=0.0d0
17400               gvdwc_pepbase(j,i)=0.0d0
17401               gvdwx_scpho(j,i)=0.0d0
17402               gvdwc_scpho(j,i)=0.0d0
17403               gvdwc_peppho(j,i)=0.0d0
17404             enddo
17405              enddo
17406             do i=0,nres
17407             do j=1,3
17408               do intertyp=1,3
17409                gloc_sc(intertyp,i,icg)=0.0d0
17410               enddo
17411             enddo
17412             enddo
17413             do i=1,nres
17414              do j=1,maxcontsshi
17415              shield_list(j,i)=0
17416             do k=1,3
17417       !C           print *,i,j,k
17418                grad_shield_side(k,j,i)=0.0d0
17419                grad_shield_loc(k,j,i)=0.0d0
17420              enddo
17421              enddo
17422              ishield_list(i)=0
17423             enddo
17424
17425       !
17426       ! Initialize the gradient of local energy terms.
17427       !
17428       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17429       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17430       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17431       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17432       !      allocate(gel_loc_turn3(nres))
17433       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17434       !      allocate(gsccor_loc(nres))      !(maxres)
17435
17436             do i=1,4*nres
17437             gloc(i,icg)=0.0D0
17438             enddo
17439             do i=1,nres
17440             gel_loc_loc(i)=0.0d0
17441             gcorr_loc(i)=0.0d0
17442             g_corr5_loc(i)=0.0d0
17443             g_corr6_loc(i)=0.0d0
17444             gel_loc_turn3(i)=0.0d0
17445             gel_loc_turn4(i)=0.0d0
17446             gel_loc_turn6(i)=0.0d0
17447             gsccor_loc(i)=0.0d0
17448             enddo
17449       ! initialize gcart and gxcart
17450       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17451             do i=0,nres
17452             do j=1,3
17453               gcart(j,i)=0.0d0
17454               gxcart(j,i)=0.0d0
17455             enddo
17456             enddo
17457             return
17458             end subroutine zerograd
17459       !-----------------------------------------------------------------------------
17460             real(kind=8) function fdum()
17461             fdum=0.0D0
17462             return
17463             end function fdum
17464       !-----------------------------------------------------------------------------
17465       ! intcartderiv.F
17466       !-----------------------------------------------------------------------------
17467             subroutine intcartderiv
17468       !      implicit real*8 (a-h,o-z)
17469       !      include 'DIMENSIONS'
17470 #ifdef MPI
17471             include 'mpif.h'
17472 #endif
17473       !      include 'COMMON.SETUP'
17474       !      include 'COMMON.CHAIN'
17475       !      include 'COMMON.VAR'
17476       !      include 'COMMON.GEO'
17477       !      include 'COMMON.INTERACT'
17478       !      include 'COMMON.DERIV'
17479       !      include 'COMMON.IOUNITS'
17480       !      include 'COMMON.LOCAL'
17481       !      include 'COMMON.SCCOR'
17482             real(kind=8) :: pi4,pi34
17483             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17484             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17485                       dcosomega,dsinomega !(3,3,maxres)
17486             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17487
17488             integer :: i,j,k
17489             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17490                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17491                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17492                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
17493             integer :: nres2
17494             nres2=2*nres
17495
17496       !el from module energy-------------
17497       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17498       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17499       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17500
17501       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17502       !el      allocate(dsintau(3,3,3,0:nres2))
17503       !el      allocate(dtauangle(3,3,3,0:nres2))
17504       !el      allocate(domicron(3,2,2,0:nres2))
17505       !el      allocate(dcosomicron(3,2,2,0:nres2))
17506
17507
17508
17509 #if defined(MPI) && defined(PARINTDER)
17510             if (nfgtasks.gt.1 .and. me.eq.king) &
17511             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17512 #endif
17513             pi4 = 0.5d0*pipol
17514             pi34 = 3*pi4
17515
17516       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17517       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17518
17519       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17520             do i=1,nres
17521             do j=1,3
17522               dtheta(j,1,i)=0.0d0
17523               dtheta(j,2,i)=0.0d0
17524               dphi(j,1,i)=0.0d0
17525               dphi(j,2,i)=0.0d0
17526               dphi(j,3,i)=0.0d0
17527               dcosomicron(j,1,1,i)=0.0d0
17528               dcosomicron(j,1,2,i)=0.0d0
17529               dcosomicron(j,2,1,i)=0.0d0
17530               dcosomicron(j,2,2,i)=0.0d0
17531             enddo
17532             enddo
17533       ! Derivatives of theta's
17534 #if defined(MPI) && defined(PARINTDER)
17535       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17536             do i=max0(ithet_start-1,3),ithet_end
17537 #else
17538             do i=3,nres
17539 #endif
17540             cost=dcos(theta(i))
17541             sint=sqrt(1-cost*cost)
17542             do j=1,3
17543               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17544               vbld(i-1)
17545               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17546               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17547               vbld(i)
17548               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17549             enddo
17550             enddo
17551 #if defined(MPI) && defined(PARINTDER)
17552       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17553             do i=max0(ithet_start-1,3),ithet_end
17554 #else
17555             do i=3,nres
17556 #endif
17557             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17558             cost1=dcos(omicron(1,i))
17559             sint1=sqrt(1-cost1*cost1)
17560             cost2=dcos(omicron(2,i))
17561             sint2=sqrt(1-cost2*cost2)
17562              do j=1,3
17563       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17564               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17565               cost1*dc_norm(j,i-2))/ &
17566               vbld(i-1)
17567               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17568               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17569               +cost1*(dc_norm(j,i-1+nres)))/ &
17570               vbld(i-1+nres)
17571               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17572       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17573       !C Looks messy but better than if in loop
17574               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17575               +cost2*dc_norm(j,i-1))/ &
17576               vbld(i)
17577               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17578               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17579                +cost2*(-dc_norm(j,i-1+nres)))/ &
17580               vbld(i-1+nres)
17581       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17582               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17583             enddo
17584              endif
17585             enddo
17586       !elwrite(iout,*) "after vbld write"
17587       ! Derivatives of phi:
17588       ! If phi is 0 or 180 degrees, then the formulas
17589       ! have to be derived by power series expansion of the
17590       ! conventional formulas around 0 and 180.
17591 #ifdef PARINTDER
17592             do i=iphi1_start,iphi1_end
17593 #else
17594             do i=4,nres
17595 #endif
17596       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17597       ! the conventional case
17598             sint=dsin(theta(i))
17599             sint1=dsin(theta(i-1))
17600             sing=dsin(phi(i))
17601             cost=dcos(theta(i))
17602             cost1=dcos(theta(i-1))
17603             cosg=dcos(phi(i))
17604             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17605             fac0=1.0d0/(sint1*sint)
17606             fac1=cost*fac0
17607             fac2=cost1*fac0
17608             fac3=cosg*cost1/(sint1*sint1)
17609             fac4=cosg*cost/(sint*sint)
17610       !    Obtaining the gamma derivatives from sine derivative
17611              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17612                phi(i).gt.pi34.and.phi(i).le.pi.or. &
17613                phi(i).ge.-pi.and.phi(i).le.-pi34) then
17614              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17615              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17616              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17617              do j=1,3
17618                 ctgt=cost/sint
17619                 ctgt1=cost1/sint1
17620                 cosg_inv=1.0d0/cosg
17621                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17622                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17623                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17624                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17625                 dsinphi(j,2,i)= &
17626                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17627                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17628                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17629                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17630                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17631       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17632                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17633                 endif
17634       ! Bug fixed 3/24/05 (AL)
17635              enddo
17636       !   Obtaining the gamma derivatives from cosine derivative
17637             else
17638                do j=1,3
17639                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17640                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17641                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17642                dc_norm(j,i-3))/vbld(i-2)
17643                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17644                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17645                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17646                dcostheta(j,1,i)
17647                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17648                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17649                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17650                dc_norm(j,i-1))/vbld(i)
17651                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17652 !#define DEBUG
17653 #ifdef DEBUG
17654                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17655 #endif
17656 !#undef DEBUG
17657                endif
17658              enddo
17659             endif
17660             enddo
17661       !alculate derivative of Tauangle
17662 #ifdef PARINTDER
17663             do i=itau_start,itau_end
17664 #else
17665             do i=3,nres
17666       !elwrite(iout,*) " vecpr",i,nres
17667 #endif
17668              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17669       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17670       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17671       !c dtauangle(j,intertyp,dervityp,residue number)
17672       !c INTERTYP=1 SC...Ca...Ca..Ca
17673       ! the conventional case
17674             sint=dsin(theta(i))
17675             sint1=dsin(omicron(2,i-1))
17676             sing=dsin(tauangle(1,i))
17677             cost=dcos(theta(i))
17678             cost1=dcos(omicron(2,i-1))
17679             cosg=dcos(tauangle(1,i))
17680       !elwrite(iout,*) " vecpr5",i,nres
17681             do j=1,3
17682       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17683       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17684             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17685       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17686             enddo
17687             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17688             fac0=1.0d0/(sint1*sint)
17689             fac1=cost*fac0
17690             fac2=cost1*fac0
17691             fac3=cosg*cost1/(sint1*sint1)
17692             fac4=cosg*cost/(sint*sint)
17693       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17694       !    Obtaining the gamma derivatives from sine derivative
17695              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17696                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17697                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17698              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17699              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17700              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17701             do j=1,3
17702                 ctgt=cost/sint
17703                 ctgt1=cost1/sint1
17704                 cosg_inv=1.0d0/cosg
17705                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17706              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17707              *vbld_inv(i-2+nres)
17708                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17709                 dsintau(j,1,2,i)= &
17710                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17711                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17712       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17713                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17714       ! Bug fixed 3/24/05 (AL)
17715                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17716                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17717       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17718                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17719              enddo
17720       !   Obtaining the gamma derivatives from cosine derivative
17721             else
17722                do j=1,3
17723                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17724                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17725                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17726                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17727                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17728                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17729                dcostheta(j,1,i)
17730                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17731                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17732                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17733                dc_norm(j,i-1))/vbld(i)
17734                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17735       !         write (iout,*) "else",i
17736              enddo
17737             endif
17738       !        do k=1,3
17739       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17740       !        enddo
17741             enddo
17742       !C Second case Ca...Ca...Ca...SC
17743 #ifdef PARINTDER
17744             do i=itau_start,itau_end
17745 #else
17746             do i=4,nres
17747 #endif
17748              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17749               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17750       ! the conventional case
17751             sint=dsin(omicron(1,i))
17752             sint1=dsin(theta(i-1))
17753             sing=dsin(tauangle(2,i))
17754             cost=dcos(omicron(1,i))
17755             cost1=dcos(theta(i-1))
17756             cosg=dcos(tauangle(2,i))
17757       !        do j=1,3
17758       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17759       !        enddo
17760             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17761             fac0=1.0d0/(sint1*sint)
17762             fac1=cost*fac0
17763             fac2=cost1*fac0
17764             fac3=cosg*cost1/(sint1*sint1)
17765             fac4=cosg*cost/(sint*sint)
17766       !    Obtaining the gamma derivatives from sine derivative
17767              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17768                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17769                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17770              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17771              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17772              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17773             do j=1,3
17774                 ctgt=cost/sint
17775                 ctgt1=cost1/sint1
17776                 cosg_inv=1.0d0/cosg
17777                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17778                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17779       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17780       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17781                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17782                 dsintau(j,2,2,i)= &
17783                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17784                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17785       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17786       !     & sing*ctgt*domicron(j,1,2,i),
17787       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17788                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17789       ! Bug fixed 3/24/05 (AL)
17790                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17791                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17792       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17793                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17794              enddo
17795       !   Obtaining the gamma derivatives from cosine derivative
17796             else
17797                do j=1,3
17798                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17799                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17800                dc_norm(j,i-3))/vbld(i-2)
17801                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17802                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17803                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17804                dcosomicron(j,1,1,i)
17805                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17806                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17807                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17808                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17809                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17810       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17811              enddo
17812             endif
17813             enddo
17814
17815       !CC third case SC...Ca...Ca...SC
17816 #ifdef PARINTDER
17817
17818             do i=itau_start,itau_end
17819 #else
17820             do i=3,nres
17821 #endif
17822       ! the conventional case
17823             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17824             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17825             sint=dsin(omicron(1,i))
17826             sint1=dsin(omicron(2,i-1))
17827             sing=dsin(tauangle(3,i))
17828             cost=dcos(omicron(1,i))
17829             cost1=dcos(omicron(2,i-1))
17830             cosg=dcos(tauangle(3,i))
17831             do j=1,3
17832             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17833       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17834             enddo
17835             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17836             fac0=1.0d0/(sint1*sint)
17837             fac1=cost*fac0
17838             fac2=cost1*fac0
17839             fac3=cosg*cost1/(sint1*sint1)
17840             fac4=cosg*cost/(sint*sint)
17841       !    Obtaining the gamma derivatives from sine derivative
17842              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17843                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17844                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17845              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17846              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17847              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17848             do j=1,3
17849                 ctgt=cost/sint
17850                 ctgt1=cost1/sint1
17851                 cosg_inv=1.0d0/cosg
17852                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17853                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17854                   *vbld_inv(i-2+nres)
17855                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17856                 dsintau(j,3,2,i)= &
17857                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17858                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17859                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17860       ! Bug fixed 3/24/05 (AL)
17861                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17862                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17863                   *vbld_inv(i-1+nres)
17864       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17865                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17866              enddo
17867       !   Obtaining the gamma derivatives from cosine derivative
17868             else
17869                do j=1,3
17870                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17871                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17872                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17873                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17874                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17875                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17876                dcosomicron(j,1,1,i)
17877                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17878                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17879                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17880                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17881                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17882       !          write(iout,*) "else",i
17883              enddo
17884             endif
17885             enddo
17886
17887 #ifdef CRYST_SC
17888       !   Derivatives of side-chain angles alpha and omega
17889 #if defined(MPI) && defined(PARINTDER)
17890             do i=ibond_start,ibond_end
17891 #else
17892             do i=2,nres-1
17893 #endif
17894               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17895                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17896                  fac6=fac5/vbld(i)
17897                  fac7=fac5*fac5
17898                  fac8=fac5/vbld(i+1)
17899                  fac9=fac5/vbld(i+nres)
17900                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17901                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17902                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17903                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17904                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17905                  sina=sqrt(1-cosa*cosa)
17906                  sino=dsin(omeg(i))
17907       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17908                  do j=1,3
17909                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17910                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17911                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17912                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17913                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17914                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17915                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17916                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17917                   vbld(i+nres))
17918                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17919                 enddo
17920       ! obtaining the derivatives of omega from sines
17921                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17922                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17923                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17924                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17925                    dsin(theta(i+1)))
17926                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17927                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17928                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17929                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17930                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17931                    coso_inv=1.0d0/dcos(omeg(i))
17932                    do j=1,3
17933                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17934                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17935                    (sino*dc_norm(j,i-1))/vbld(i)
17936                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17937                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17938                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17939                    -sino*dc_norm(j,i)/vbld(i+1)
17940                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17941                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17942                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17943                    vbld(i+nres)
17944                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17945                   enddo
17946                else
17947       !   obtaining the derivatives of omega from cosines
17948                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17949                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17950                  fac12=fac10*sina
17951                  fac13=fac12*fac12
17952                  fac14=sina*sina
17953                  do j=1,3
17954                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17955                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17956                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17957                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17958                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17959                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17960                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17961                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17962                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17963                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17964                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17965                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17966                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17967                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17968                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17969                 enddo
17970               endif
17971              else
17972                do j=1,3
17973                  do k=1,3
17974                    dalpha(k,j,i)=0.0d0
17975                    domega(k,j,i)=0.0d0
17976                  enddo
17977                enddo
17978              endif
17979              enddo
17980 #endif
17981 #if defined(MPI) && defined(PARINTDER)
17982             if (nfgtasks.gt.1) then
17983 #ifdef DEBUG
17984       !d      write (iout,*) "Gather dtheta"
17985       !d      call flush(iout)
17986             write (iout,*) "dtheta before gather"
17987             do i=1,nres
17988             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17989             enddo
17990 #endif
17991             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17992             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17993             king,FG_COMM,IERROR)
17994 !#define DEBUG
17995 #ifdef DEBUG
17996       !d      write (iout,*) "Gather dphi"
17997       !d      call flush(iout)
17998             write (iout,*) "dphi before gather"
17999             do i=1,nres
18000             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18001             enddo
18002 #endif
18003 !#undef DEBUG
18004             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18005             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18006             king,FG_COMM,IERROR)
18007       !d      write (iout,*) "Gather dalpha"
18008       !d      call flush(iout)
18009 #ifdef CRYST_SC
18010             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18011             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18012             king,FG_COMM,IERROR)
18013       !d      write (iout,*) "Gather domega"
18014       !d      call flush(iout)
18015             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18016             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18017             king,FG_COMM,IERROR)
18018 #endif
18019             endif
18020 #endif
18021 !#define DEBUG
18022 #ifdef DEBUG
18023             write (iout,*) "dtheta after gather"
18024             do i=1,nres
18025             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18026             enddo
18027             write (iout,*) "dphi after gather"
18028             do i=1,nres
18029             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18030             enddo
18031             write (iout,*) "dalpha after gather"
18032             do i=1,nres
18033             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18034             enddo
18035             write (iout,*) "domega after gather"
18036             do i=1,nres
18037             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18038             enddo
18039 #endif
18040 !#undef DEBUG
18041             return
18042             end subroutine intcartderiv
18043       !-----------------------------------------------------------------------------
18044             subroutine checkintcartgrad
18045       !      implicit real*8 (a-h,o-z)
18046       !      include 'DIMENSIONS'
18047 #ifdef MPI
18048             include 'mpif.h'
18049 #endif
18050       !      include 'COMMON.CHAIN'
18051       !      include 'COMMON.VAR'
18052       !      include 'COMMON.GEO'
18053       !      include 'COMMON.INTERACT'
18054       !      include 'COMMON.DERIV'
18055       !      include 'COMMON.IOUNITS'
18056       !      include 'COMMON.SETUP'
18057             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18058             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18059             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18060             real(kind=8),dimension(3) :: dc_norm_s
18061             real(kind=8) :: aincr=1.0d-5
18062             integer :: i,j
18063             real(kind=8) :: dcji
18064             do i=1,nres
18065             phi_s(i)=phi(i)
18066             theta_s(i)=theta(i)
18067             alph_s(i)=alph(i)
18068             omeg_s(i)=omeg(i)
18069             enddo
18070       ! Check theta gradient
18071             write (iout,*) &
18072              "Analytical (upper) and numerical (lower) gradient of theta"
18073             write (iout,*)
18074             do i=3,nres
18075             do j=1,3
18076               dcji=dc(j,i-2)
18077               dc(j,i-2)=dcji+aincr
18078               call chainbuild_cart
18079               call int_from_cart1(.false.)
18080           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18081           dc(j,i-2)=dcji
18082           dcji=dc(j,i-1)
18083           dc(j,i-1)=dc(j,i-1)+aincr
18084           call chainbuild_cart
18085           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18086           dc(j,i-1)=dcji
18087         enddo
18088 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18089 !el          (dtheta(j,2,i),j=1,3)
18090 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18091 !el          (dthetanum(j,2,i),j=1,3)
18092 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18093 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18094 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18095 !el        write (iout,*)
18096       enddo
18097 ! Check gamma gradient
18098       write (iout,*) &
18099        "Analytical (upper) and numerical (lower) gradient of gamma"
18100       do i=4,nres
18101         do j=1,3
18102           dcji=dc(j,i-3)
18103           dc(j,i-3)=dcji+aincr
18104           call chainbuild_cart
18105           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18106               dc(j,i-3)=dcji
18107           dcji=dc(j,i-2)
18108           dc(j,i-2)=dcji+aincr
18109           call chainbuild_cart
18110           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18111           dc(j,i-2)=dcji
18112           dcji=dc(j,i-1)
18113           dc(j,i-1)=dc(j,i-1)+aincr
18114           call chainbuild_cart
18115           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18116           dc(j,i-1)=dcji
18117         enddo
18118 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18119 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18120 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18121 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18122 !el        write (iout,'(5x,3(3f10.5,5x))') &
18123 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18124 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18125 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18126 !el        write (iout,*)
18127       enddo
18128 ! Check alpha gradient
18129       write (iout,*) &
18130        "Analytical (upper) and numerical (lower) gradient of alpha"
18131       do i=2,nres-1
18132        if(itype(i,1).ne.10) then
18133                  do j=1,3
18134                   dcji=dc(j,i-1)
18135                    dc(j,i-1)=dcji+aincr
18136               call chainbuild_cart
18137               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18138                  /aincr
18139                   dc(j,i-1)=dcji
18140               dcji=dc(j,i)
18141               dc(j,i)=dcji+aincr
18142               call chainbuild_cart
18143               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18144                  /aincr
18145               dc(j,i)=dcji
18146               dcji=dc(j,i+nres)
18147               dc(j,i+nres)=dc(j,i+nres)+aincr
18148               call chainbuild_cart
18149               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18150                  /aincr
18151              dc(j,i+nres)=dcji
18152             enddo
18153           endif
18154 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18155 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18156 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18157 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18158 !el        write (iout,'(5x,3(3f10.5,5x))') &
18159 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18160 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18161 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18162 !el        write (iout,*)
18163       enddo
18164 !     Check omega gradient
18165       write (iout,*) &
18166        "Analytical (upper) and numerical (lower) gradient of omega"
18167       do i=2,nres-1
18168        if(itype(i,1).ne.10) then
18169                  do j=1,3
18170                   dcji=dc(j,i-1)
18171                    dc(j,i-1)=dcji+aincr
18172               call chainbuild_cart
18173               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18174                  /aincr
18175                   dc(j,i-1)=dcji
18176               dcji=dc(j,i)
18177               dc(j,i)=dcji+aincr
18178               call chainbuild_cart
18179               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18180                  /aincr
18181               dc(j,i)=dcji
18182               dcji=dc(j,i+nres)
18183               dc(j,i+nres)=dc(j,i+nres)+aincr
18184               call chainbuild_cart
18185               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18186                  /aincr
18187              dc(j,i+nres)=dcji
18188             enddo
18189           endif
18190 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18191 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18192 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18193 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18194 !el        write (iout,'(5x,3(3f10.5,5x))') &
18195 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18196 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18197 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18198 !el        write (iout,*)
18199       enddo
18200       return
18201       end subroutine checkintcartgrad
18202 !-----------------------------------------------------------------------------
18203 ! q_measure.F
18204 !-----------------------------------------------------------------------------
18205       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18206 !      implicit real*8 (a-h,o-z)
18207 !      include 'DIMENSIONS'
18208 !      include 'COMMON.IOUNITS'
18209 !      include 'COMMON.CHAIN'
18210 !      include 'COMMON.INTERACT'
18211 !      include 'COMMON.VAR'
18212       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18213       integer :: kkk,nsep=3
18214       real(kind=8) :: qm      !dist,
18215       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18216       logical :: lprn=.false.
18217       logical :: flag
18218 !      real(kind=8) :: sigm,x
18219
18220 !el      sigm(x)=0.25d0*x     ! local function
18221       qqmax=1.0d10
18222       do kkk=1,nperm
18223       qq = 0.0d0
18224       nl=0
18225        if(flag) then
18226         do il=seg1+nsep,seg2
18227           do jl=seg1,il-nsep
18228             nl=nl+1
18229             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18230                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18231                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18232             dij=dist(il,jl)
18233             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18234             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18235               nl=nl+1
18236               d0ijCM=dsqrt( &
18237                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18238                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18239                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18240               dijCM=dist(il+nres,jl+nres)
18241               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18242             endif
18243             qq = qq+qqij+qqijCM
18244           enddo
18245         enddo
18246         qq = qq/nl
18247       else
18248       do il=seg1,seg2
18249         if((seg3-il).lt.3) then
18250              secseg=il+3
18251         else
18252              secseg=seg3
18253         endif
18254           do jl=secseg,seg4
18255             nl=nl+1
18256             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18257                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18258                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18259             dij=dist(il,jl)
18260             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18261             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18262               nl=nl+1
18263               d0ijCM=dsqrt( &
18264                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18265                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18266                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18267               dijCM=dist(il+nres,jl+nres)
18268               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18269             endif
18270             qq = qq+qqij+qqijCM
18271           enddo
18272         enddo
18273       qq = qq/nl
18274       endif
18275       if (qqmax.le.qq) qqmax=qq
18276       enddo
18277       qwolynes=1.0d0-qqmax
18278       return
18279       end function qwolynes
18280 !-----------------------------------------------------------------------------
18281       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18282 !      implicit real*8 (a-h,o-z)
18283 !      include 'DIMENSIONS'
18284 !      include 'COMMON.IOUNITS'
18285 !      include 'COMMON.CHAIN'
18286 !      include 'COMMON.INTERACT'
18287 !      include 'COMMON.VAR'
18288 !      include 'COMMON.MD'
18289       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18290       integer :: nsep=3, kkk
18291 !el      real(kind=8) :: dist
18292       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18293       logical :: lprn=.false.
18294       logical :: flag
18295       real(kind=8) :: sim,dd0,fac,ddqij
18296 !el      sigm(x)=0.25d0*x           ! local function
18297       do kkk=1,nperm
18298       do i=0,nres
18299         do j=1,3
18300           dqwol(j,i)=0.0d0
18301           dxqwol(j,i)=0.0d0
18302         enddo
18303       enddo
18304       nl=0
18305        if(flag) then
18306         do il=seg1+nsep,seg2
18307           do jl=seg1,il-nsep
18308             nl=nl+1
18309             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18310                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18311                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18312             dij=dist(il,jl)
18313             sim = 1.0d0/sigm(d0ij)
18314             sim = sim*sim
18315             dd0 = dij-d0ij
18316             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18317           do k=1,3
18318               ddqij = (c(k,il)-c(k,jl))*fac
18319               dqwol(k,il)=dqwol(k,il)+ddqij
18320               dqwol(k,jl)=dqwol(k,jl)-ddqij
18321             enddo
18322
18323             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18324               nl=nl+1
18325               d0ijCM=dsqrt( &
18326                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18327                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18328                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18329               dijCM=dist(il+nres,jl+nres)
18330               sim = 1.0d0/sigm(d0ijCM)
18331               sim = sim*sim
18332               dd0=dijCM-d0ijCM
18333               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18334               do k=1,3
18335                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18336                 dxqwol(k,il)=dxqwol(k,il)+ddqij
18337                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18338               enddo
18339             endif
18340           enddo
18341         enddo
18342        else
18343         do il=seg1,seg2
18344         if((seg3-il).lt.3) then
18345              secseg=il+3
18346         else
18347              secseg=seg3
18348         endif
18349           do jl=secseg,seg4
18350             nl=nl+1
18351             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18352                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18353                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18354             dij=dist(il,jl)
18355             sim = 1.0d0/sigm(d0ij)
18356             sim = sim*sim
18357             dd0 = dij-d0ij
18358             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18359             do k=1,3
18360               ddqij = (c(k,il)-c(k,jl))*fac
18361               dqwol(k,il)=dqwol(k,il)+ddqij
18362               dqwol(k,jl)=dqwol(k,jl)-ddqij
18363             enddo
18364             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18365               nl=nl+1
18366               d0ijCM=dsqrt( &
18367                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18368                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18369                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18370               dijCM=dist(il+nres,jl+nres)
18371               sim = 1.0d0/sigm(d0ijCM)
18372               sim=sim*sim
18373               dd0 = dijCM-d0ijCM
18374               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18375               do k=1,3
18376                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18377                dxqwol(k,il)=dxqwol(k,il)+ddqij
18378                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18379               enddo
18380             endif
18381           enddo
18382         enddo
18383       endif
18384       enddo
18385        do i=0,nres
18386          do j=1,3
18387            dqwol(j,i)=dqwol(j,i)/nl
18388            dxqwol(j,i)=dxqwol(j,i)/nl
18389          enddo
18390        enddo
18391       return
18392       end subroutine qwolynes_prim
18393 !-----------------------------------------------------------------------------
18394       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18395 !      implicit real*8 (a-h,o-z)
18396 !      include 'DIMENSIONS'
18397 !      include 'COMMON.IOUNITS'
18398 !      include 'COMMON.CHAIN'
18399 !      include 'COMMON.INTERACT'
18400 !      include 'COMMON.VAR'
18401       integer :: seg1,seg2,seg3,seg4
18402       logical :: flag
18403       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18404       real(kind=8),dimension(3,0:2*nres) :: cdummy
18405       real(kind=8) :: q1,q2
18406       real(kind=8) :: delta=1.0d-10
18407       integer :: i,j
18408
18409       do i=0,nres
18410         do j=1,3
18411           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18412           cdummy(j,i)=c(j,i)
18413           c(j,i)=c(j,i)+delta
18414           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18415           qwolan(j,i)=(q2-q1)/delta
18416           c(j,i)=cdummy(j,i)
18417         enddo
18418       enddo
18419       do i=0,nres
18420         do j=1,3
18421           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18422           cdummy(j,i+nres)=c(j,i+nres)
18423           c(j,i+nres)=c(j,i+nres)+delta
18424           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18425           qwolxan(j,i)=(q2-q1)/delta
18426           c(j,i+nres)=cdummy(j,i+nres)
18427         enddo
18428       enddo
18429 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18430 !      do i=0,nct
18431 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18432 !      enddo
18433 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18434 !      do i=0,nct
18435 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18436 !      enddo
18437       return
18438       end subroutine qwol_num
18439 !-----------------------------------------------------------------------------
18440       subroutine EconstrQ
18441 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18442 !      implicit real*8 (a-h,o-z)
18443 !      include 'DIMENSIONS'
18444 !      include 'COMMON.CONTROL'
18445 !      include 'COMMON.VAR'
18446 !      include 'COMMON.MD'
18447       use MD_data
18448 !#ifndef LANG0
18449 !      include 'COMMON.LANGEVIN'
18450 !#else
18451 !      include 'COMMON.LANGEVIN.lang0'
18452 !#endif
18453 !      include 'COMMON.CHAIN'
18454 !      include 'COMMON.DERIV'
18455 !      include 'COMMON.GEO'
18456 !      include 'COMMON.LOCAL'
18457 !      include 'COMMON.INTERACT'
18458 !      include 'COMMON.IOUNITS'
18459 !      include 'COMMON.NAMES'
18460 !      include 'COMMON.TIME1'
18461       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18462       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18463                    duconst,duxconst
18464       integer :: kstart,kend,lstart,lend,idummy
18465       real(kind=8) :: delta=1.0d-7
18466       integer :: i,j,k,ii
18467       do i=0,nres
18468          do j=1,3
18469             duconst(j,i)=0.0d0
18470             dudconst(j,i)=0.0d0
18471             duxconst(j,i)=0.0d0
18472             dudxconst(j,i)=0.0d0
18473          enddo
18474       enddo
18475       Uconst=0.0d0
18476       do i=1,nfrag
18477          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18478            idummy,idummy)
18479          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18480 ! Calculating the derivatives of Constraint energy with respect to Q
18481          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18482            qinfrag(i,iset))
18483 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18484 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18485 !         hmnum=(hm2-hm1)/delta
18486 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18487 !     &   qinfrag(i,iset))
18488 !         write(iout,*) "harmonicnum frag", hmnum
18489 ! Calculating the derivatives of Q with respect to cartesian coordinates
18490          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18491           idummy,idummy)
18492 !         write(iout,*) "dqwol "
18493 !         do ii=1,nres
18494 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18495 !         enddo
18496 !         write(iout,*) "dxqwol "
18497 !         do ii=1,nres
18498 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18499 !         enddo
18500 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18501 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18502 !     &  ,idummy,idummy)
18503 !  The gradients of Uconst in Cs
18504          do ii=0,nres
18505             do j=1,3
18506                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18507                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18508             enddo
18509          enddo
18510       enddo
18511       do i=1,npair
18512          kstart=ifrag(1,ipair(1,i,iset),iset)
18513          kend=ifrag(2,ipair(1,i,iset),iset)
18514          lstart=ifrag(1,ipair(2,i,iset),iset)
18515          lend=ifrag(2,ipair(2,i,iset),iset)
18516          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18517          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18518 !  Calculating dU/dQ
18519          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18520 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18521 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18522 !         hmnum=(hm2-hm1)/delta
18523 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18524 !     &   qinpair(i,iset))
18525 !         write(iout,*) "harmonicnum pair ", hmnum
18526 ! Calculating dQ/dXi
18527          call qwolynes_prim(kstart,kend,.false.,&
18528           lstart,lend)
18529 !         write(iout,*) "dqwol "
18530 !         do ii=1,nres
18531 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18532 !         enddo
18533 !         write(iout,*) "dxqwol "
18534 !         do ii=1,nres
18535 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18536 !        enddo
18537 ! Calculating numerical gradients
18538 !        call qwol_num(kstart,kend,.false.
18539 !     &  ,lstart,lend)
18540 ! The gradients of Uconst in Cs
18541          do ii=0,nres
18542             do j=1,3
18543                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18544                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18545             enddo
18546          enddo
18547       enddo
18548 !      write(iout,*) "Uconst inside subroutine ", Uconst
18549 ! Transforming the gradients from Cs to dCs for the backbone
18550       do i=0,nres
18551          do j=i+1,nres
18552            do k=1,3
18553              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18554            enddo
18555          enddo
18556       enddo
18557 !  Transforming the gradients from Cs to dCs for the side chains
18558       do i=1,nres
18559          do j=1,3
18560            dudxconst(j,i)=duxconst(j,i)
18561          enddo
18562       enddo
18563 !      write(iout,*) "dU/ddc backbone "
18564 !       do ii=0,nres
18565 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18566 !      enddo
18567 !      write(iout,*) "dU/ddX side chain "
18568 !      do ii=1,nres
18569 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18570 !      enddo
18571 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18572 !      call dEconstrQ_num
18573       return
18574       end subroutine EconstrQ
18575 !-----------------------------------------------------------------------------
18576       subroutine dEconstrQ_num
18577 ! Calculating numerical dUconst/ddc and dUconst/ddx
18578 !      implicit real*8 (a-h,o-z)
18579 !      include 'DIMENSIONS'
18580 !      include 'COMMON.CONTROL'
18581 !      include 'COMMON.VAR'
18582 !      include 'COMMON.MD'
18583       use MD_data
18584 !#ifndef LANG0
18585 !      include 'COMMON.LANGEVIN'
18586 !#else
18587 !      include 'COMMON.LANGEVIN.lang0'
18588 !#endif
18589 !      include 'COMMON.CHAIN'
18590 !      include 'COMMON.DERIV'
18591 !      include 'COMMON.GEO'
18592 !      include 'COMMON.LOCAL'
18593 !      include 'COMMON.INTERACT'
18594 !      include 'COMMON.IOUNITS'
18595 !      include 'COMMON.NAMES'
18596 !      include 'COMMON.TIME1'
18597       real(kind=8) :: uzap1,uzap2
18598       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18599       integer :: kstart,kend,lstart,lend,idummy
18600       real(kind=8) :: delta=1.0d-7
18601 !el local variables
18602       integer :: i,ii,j
18603 !     real(kind=8) ::
18604 !     For the backbone
18605       do i=0,nres-1
18606          do j=1,3
18607             dUcartan(j,i)=0.0d0
18608             cdummy(j,i)=dc(j,i)
18609             dc(j,i)=dc(j,i)+delta
18610             call chainbuild_cart
18611           uzap2=0.0d0
18612             do ii=1,nfrag
18613              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18614                 idummy,idummy)
18615                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18616                 qinfrag(ii,iset))
18617             enddo
18618             do ii=1,npair
18619                kstart=ifrag(1,ipair(1,ii,iset),iset)
18620                kend=ifrag(2,ipair(1,ii,iset),iset)
18621                lstart=ifrag(1,ipair(2,ii,iset),iset)
18622                lend=ifrag(2,ipair(2,ii,iset),iset)
18623                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18624                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18625                  qinpair(ii,iset))
18626             enddo
18627             dc(j,i)=cdummy(j,i)
18628             call chainbuild_cart
18629             uzap1=0.0d0
18630              do ii=1,nfrag
18631              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18632                 idummy,idummy)
18633                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18634                 qinfrag(ii,iset))
18635             enddo
18636             do ii=1,npair
18637                kstart=ifrag(1,ipair(1,ii,iset),iset)
18638                kend=ifrag(2,ipair(1,ii,iset),iset)
18639                lstart=ifrag(1,ipair(2,ii,iset),iset)
18640                lend=ifrag(2,ipair(2,ii,iset),iset)
18641                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18642                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18643                 qinpair(ii,iset))
18644             enddo
18645             ducartan(j,i)=(uzap2-uzap1)/(delta)
18646          enddo
18647       enddo
18648 ! Calculating numerical gradients for dU/ddx
18649       do i=0,nres-1
18650          duxcartan(j,i)=0.0d0
18651          do j=1,3
18652             cdummy(j,i)=dc(j,i+nres)
18653             dc(j,i+nres)=dc(j,i+nres)+delta
18654             call chainbuild_cart
18655           uzap2=0.0d0
18656             do ii=1,nfrag
18657              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18658                 idummy,idummy)
18659                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18660                 qinfrag(ii,iset))
18661             enddo
18662             do ii=1,npair
18663                kstart=ifrag(1,ipair(1,ii,iset),iset)
18664                kend=ifrag(2,ipair(1,ii,iset),iset)
18665                lstart=ifrag(1,ipair(2,ii,iset),iset)
18666                lend=ifrag(2,ipair(2,ii,iset),iset)
18667                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18668                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18669                 qinpair(ii,iset))
18670             enddo
18671             dc(j,i+nres)=cdummy(j,i)
18672             call chainbuild_cart
18673             uzap1=0.0d0
18674              do ii=1,nfrag
18675                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18676                 ifrag(2,ii,iset),.true.,idummy,idummy)
18677                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18678                 qinfrag(ii,iset))
18679             enddo
18680             do ii=1,npair
18681                kstart=ifrag(1,ipair(1,ii,iset),iset)
18682                kend=ifrag(2,ipair(1,ii,iset),iset)
18683                lstart=ifrag(1,ipair(2,ii,iset),iset)
18684                lend=ifrag(2,ipair(2,ii,iset),iset)
18685                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18686                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18687                 qinpair(ii,iset))
18688             enddo
18689             duxcartan(j,i)=(uzap2-uzap1)/(delta)
18690          enddo
18691       enddo
18692       write(iout,*) "Numerical dUconst/ddc backbone "
18693       do ii=0,nres
18694         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18695       enddo
18696 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18697 !      do ii=1,nres
18698 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18699 !      enddo
18700       return
18701       end subroutine dEconstrQ_num
18702 !-----------------------------------------------------------------------------
18703 ! ssMD.F
18704 !-----------------------------------------------------------------------------
18705       subroutine check_energies
18706
18707 !      use random, only: ran_number
18708
18709 !      implicit none
18710 !     Includes
18711 !      include 'DIMENSIONS'
18712 !      include 'COMMON.CHAIN'
18713 !      include 'COMMON.VAR'
18714 !      include 'COMMON.IOUNITS'
18715 !      include 'COMMON.SBRIDGE'
18716 !      include 'COMMON.LOCAL'
18717 !      include 'COMMON.GEO'
18718
18719 !     External functions
18720 !EL      double precision ran_number
18721 !EL      external ran_number
18722
18723 !     Local variables
18724       integer :: i,j,k,l,lmax,p,pmax
18725       real(kind=8) :: rmin,rmax
18726       real(kind=8) :: eij
18727
18728       real(kind=8) :: d
18729       real(kind=8) :: wi,rij,tj,pj
18730 !      return
18731
18732       i=5
18733       j=14
18734
18735       d=dsc(1)
18736       rmin=2.0D0
18737       rmax=12.0D0
18738
18739       lmax=10000
18740       pmax=1
18741
18742       do k=1,3
18743         c(k,i)=0.0D0
18744         c(k,j)=0.0D0
18745         c(k,nres+i)=0.0D0
18746         c(k,nres+j)=0.0D0
18747       enddo
18748
18749       do l=1,lmax
18750
18751 !t        wi=ran_number(0.0D0,pi)
18752 !        wi=ran_number(0.0D0,pi/6.0D0)
18753 !        wi=0.0D0
18754 !t        tj=ran_number(0.0D0,pi)
18755 !t        pj=ran_number(0.0D0,pi)
18756 !        pj=ran_number(0.0D0,pi/6.0D0)
18757 !        pj=0.0D0
18758
18759         do p=1,pmax
18760 !t           rij=ran_number(rmin,rmax)
18761
18762            c(1,j)=d*sin(pj)*cos(tj)
18763            c(2,j)=d*sin(pj)*sin(tj)
18764            c(3,j)=d*cos(pj)
18765
18766            c(3,nres+i)=-rij
18767
18768            c(1,i)=d*sin(wi)
18769            c(3,i)=-rij-d*cos(wi)
18770
18771            do k=1,3
18772               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18773               dc_norm(k,nres+i)=dc(k,nres+i)/d
18774               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18775               dc_norm(k,nres+j)=dc(k,nres+j)/d
18776            enddo
18777
18778            call dyn_ssbond_ene(i,j,eij)
18779         enddo
18780       enddo
18781       call exit(1)
18782       return
18783       end subroutine check_energies
18784 !-----------------------------------------------------------------------------
18785       subroutine dyn_ssbond_ene(resi,resj,eij)
18786 !      implicit none
18787 !      Includes
18788       use calc_data
18789       use comm_sschecks
18790 !      include 'DIMENSIONS'
18791 !      include 'COMMON.SBRIDGE'
18792 !      include 'COMMON.CHAIN'
18793 !      include 'COMMON.DERIV'
18794 !      include 'COMMON.LOCAL'
18795 !      include 'COMMON.INTERACT'
18796 !      include 'COMMON.VAR'
18797 !      include 'COMMON.IOUNITS'
18798 !      include 'COMMON.CALC'
18799 #ifndef CLUST
18800 #ifndef WHAM
18801        use MD_data
18802 !      include 'COMMON.MD'
18803 !      use MD, only: totT,t_bath
18804 #endif
18805 #endif
18806 !     External functions
18807 !EL      double precision h_base
18808 !EL      external h_base
18809
18810 !     Input arguments
18811       integer :: resi,resj
18812
18813 !     Output arguments
18814       real(kind=8) :: eij
18815
18816 !     Local variables
18817       logical :: havebond
18818       integer itypi,itypj
18819       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18820       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18821       real(kind=8),dimension(3) :: dcosom1,dcosom2
18822       real(kind=8) :: ed
18823       real(kind=8) :: pom1,pom2
18824       real(kind=8) :: ljA,ljB,ljXs
18825       real(kind=8),dimension(1:3) :: d_ljB
18826       real(kind=8) :: ssA,ssB,ssC,ssXs
18827       real(kind=8) :: ssxm,ljxm,ssm,ljm
18828       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18829       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18830       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18831 !-------FIRST METHOD
18832       real(kind=8) :: xm
18833       real(kind=8),dimension(1:3) :: d_xm
18834 !-------END FIRST METHOD
18835 !-------SECOND METHOD
18836 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18837 !-------END SECOND METHOD
18838
18839 !-------TESTING CODE
18840 !el      logical :: checkstop,transgrad
18841 !el      common /sschecks/ checkstop,transgrad
18842
18843       integer :: icheck,nicheck,jcheck,njcheck
18844       real(kind=8),dimension(-1:1) :: echeck
18845       real(kind=8) :: deps,ssx0,ljx0
18846 !-------END TESTING CODE
18847
18848       eij=0.0d0
18849       i=resi
18850       j=resj
18851
18852 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18853 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18854
18855       itypi=itype(i,1)
18856       dxi=dc_norm(1,nres+i)
18857       dyi=dc_norm(2,nres+i)
18858       dzi=dc_norm(3,nres+i)
18859       dsci_inv=vbld_inv(i+nres)
18860
18861       itypj=itype(j,1)
18862       xj=c(1,nres+j)-c(1,nres+i)
18863       yj=c(2,nres+j)-c(2,nres+i)
18864       zj=c(3,nres+j)-c(3,nres+i)
18865       dxj=dc_norm(1,nres+j)
18866       dyj=dc_norm(2,nres+j)
18867       dzj=dc_norm(3,nres+j)
18868       dscj_inv=vbld_inv(j+nres)
18869
18870       chi1=chi(itypi,itypj)
18871       chi2=chi(itypj,itypi)
18872       chi12=chi1*chi2
18873       chip1=chip(itypi)
18874       chip2=chip(itypj)
18875       chip12=chip1*chip2
18876       alf1=alp(itypi)
18877       alf2=alp(itypj)
18878       alf12=0.5D0*(alf1+alf2)
18879
18880       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18881       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18882 !     The following are set in sc_angular
18883 !      erij(1)=xj*rij
18884 !      erij(2)=yj*rij
18885 !      erij(3)=zj*rij
18886 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18887 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18888 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18889       call sc_angular
18890       rij=1.0D0/rij  ! Reset this so it makes sense
18891
18892       sig0ij=sigma(itypi,itypj)
18893       sig=sig0ij*dsqrt(1.0D0/sigsq)
18894
18895       ljXs=sig-sig0ij
18896       ljA=eps1*eps2rt**2*eps3rt**2
18897       ljB=ljA*bb_aq(itypi,itypj)
18898       ljA=ljA*aa_aq(itypi,itypj)
18899       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18900
18901       ssXs=d0cm
18902       deltat1=1.0d0-om1
18903       deltat2=1.0d0+om2
18904       deltat12=om2-om1+2.0d0
18905       cosphi=om12-om1*om2
18906       ssA=akcm
18907       ssB=akct*deltat12
18908       ssC=ss_depth &
18909            +akth*(deltat1*deltat1+deltat2*deltat2) &
18910            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18911       ssxm=ssXs-0.5D0*ssB/ssA
18912
18913 !-------TESTING CODE
18914 !$$$c     Some extra output
18915 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18916 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18917 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18918 !$$$      if (ssx0.gt.0.0d0) then
18919 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18920 !$$$      else
18921 !$$$        ssx0=ssxm
18922 !$$$      endif
18923 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18924 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18925 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18926 !$$$      return
18927 !-------END TESTING CODE
18928
18929 !-------TESTING CODE
18930 !     Stop and plot energy and derivative as a function of distance
18931       if (checkstop) then
18932         ssm=ssC-0.25D0*ssB*ssB/ssA
18933         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18934         if (ssm.lt.ljm .and. &
18935              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18936           nicheck=1000
18937           njcheck=1
18938           deps=0.5d-7
18939         else
18940           checkstop=.false.
18941         endif
18942       endif
18943       if (.not.checkstop) then
18944         nicheck=0
18945         njcheck=-1
18946       endif
18947
18948       do icheck=0,nicheck
18949       do jcheck=-1,njcheck
18950       if (checkstop) rij=(ssxm-1.0d0)+ &
18951              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18952 !-------END TESTING CODE
18953
18954       if (rij.gt.ljxm) then
18955         havebond=.false.
18956         ljd=rij-ljXs
18957         fac=(1.0D0/ljd)**expon
18958         e1=fac*fac*aa_aq(itypi,itypj)
18959         e2=fac*bb_aq(itypi,itypj)
18960         eij=eps1*eps2rt*eps3rt*(e1+e2)
18961         eps2der=eij*eps3rt
18962         eps3der=eij*eps2rt
18963         eij=eij*eps2rt*eps3rt
18964
18965         sigder=-sig/sigsq
18966         e1=e1*eps1*eps2rt**2*eps3rt**2
18967         ed=-expon*(e1+eij)/ljd
18968         sigder=ed*sigder
18969         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18970         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18971         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18972              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18973       else if (rij.lt.ssxm) then
18974         havebond=.true.
18975         ssd=rij-ssXs
18976         eij=ssA*ssd*ssd+ssB*ssd+ssC
18977
18978         ed=2*akcm*ssd+akct*deltat12
18979         pom1=akct*ssd
18980         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18981         eom1=-2*akth*deltat1-pom1-om2*pom2
18982         eom2= 2*akth*deltat2+pom1-om1*pom2
18983         eom12=pom2
18984       else
18985         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18986
18987         d_ssxm(1)=0.5D0*akct/ssA
18988         d_ssxm(2)=-d_ssxm(1)
18989         d_ssxm(3)=0.0D0
18990
18991         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18992         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18993         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18994         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18995
18996 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18997         xm=0.5d0*(ssxm+ljxm)
18998         do k=1,3
18999           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19000         enddo
19001         if (rij.lt.xm) then
19002           havebond=.true.
19003           ssm=ssC-0.25D0*ssB*ssB/ssA
19004           d_ssm(1)=0.5D0*akct*ssB/ssA
19005           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19006           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19007           d_ssm(3)=omega
19008           f1=(rij-xm)/(ssxm-xm)
19009           f2=(rij-ssxm)/(xm-ssxm)
19010           h1=h_base(f1,hd1)
19011           h2=h_base(f2,hd2)
19012           eij=ssm*h1+Ht*h2
19013           delta_inv=1.0d0/(xm-ssxm)
19014           deltasq_inv=delta_inv*delta_inv
19015           fac=ssm*hd1-Ht*hd2
19016           fac1=deltasq_inv*fac*(xm-rij)
19017           fac2=deltasq_inv*fac*(rij-ssxm)
19018           ed=delta_inv*(Ht*hd2-ssm*hd1)
19019           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19020           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19021           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19022         else
19023           havebond=.false.
19024           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19025           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19026           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19027           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19028                alf12/eps3rt)
19029           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19030           f1=(rij-ljxm)/(xm-ljxm)
19031           f2=(rij-xm)/(ljxm-xm)
19032           h1=h_base(f1,hd1)
19033           h2=h_base(f2,hd2)
19034           eij=Ht*h1+ljm*h2
19035           delta_inv=1.0d0/(ljxm-xm)
19036           deltasq_inv=delta_inv*delta_inv
19037           fac=Ht*hd1-ljm*hd2
19038           fac1=deltasq_inv*fac*(ljxm-rij)
19039           fac2=deltasq_inv*fac*(rij-xm)
19040           ed=delta_inv*(ljm*hd2-Ht*hd1)
19041           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19042           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19043           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19044         endif
19045 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19046
19047 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19048 !$$$        ssd=rij-ssXs
19049 !$$$        ljd=rij-ljXs
19050 !$$$        fac1=rij-ljxm
19051 !$$$        fac2=rij-ssxm
19052 !$$$
19053 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19054 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19055 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19056 !$$$
19057 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19058 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19059 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19060 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19061 !$$$        d_ssm(3)=omega
19062 !$$$
19063 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19064 !$$$        do k=1,3
19065 !$$$          d_ljm(k)=ljm*d_ljB(k)
19066 !$$$        enddo
19067 !$$$        ljm=ljm*ljB
19068 !$$$
19069 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19070 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19071 !$$$        d_ss(2)=akct*ssd
19072 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19073 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19074 !$$$        d_ss(3)=omega
19075 !$$$
19076 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19077 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19078 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19079 !$$$        do k=1,3
19080 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19081 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19082 !$$$        enddo
19083 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19084 !$$$
19085 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19086 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19087 !$$$        h1=h_base(f1,hd1)
19088 !$$$        h2=h_base(f2,hd2)
19089 !$$$        eij=ss*h1+ljf*h2
19090 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19091 !$$$        deltasq_inv=delta_inv*delta_inv
19092 !$$$        fac=ljf*hd2-ss*hd1
19093 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19094 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19095 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19096 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19097 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19098 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19099 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19100 !$$$
19101 !$$$        havebond=.false.
19102 !$$$        if (ed.gt.0.0d0) havebond=.true.
19103 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19104
19105       endif
19106
19107       if (havebond) then
19108 !#ifndef CLUST
19109 !#ifndef WHAM
19110 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19111 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19112 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19113 !        endif
19114 !#endif
19115 !#endif
19116         dyn_ssbond_ij(i,j)=eij
19117       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19118         dyn_ssbond_ij(i,j)=1.0d300
19119 !#ifndef CLUST
19120 !#ifndef WHAM
19121 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19122 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19123 !#endif
19124 !#endif
19125       endif
19126
19127 !-------TESTING CODE
19128 !el      if (checkstop) then
19129         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19130              "CHECKSTOP",rij,eij,ed
19131         echeck(jcheck)=eij
19132 !el      endif
19133       enddo
19134       if (checkstop) then
19135         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19136       endif
19137       enddo
19138       if (checkstop) then
19139         transgrad=.true.
19140         checkstop=.false.
19141       endif
19142 !-------END TESTING CODE
19143
19144       do k=1,3
19145         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19146         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19147       enddo
19148       do k=1,3
19149         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19150       enddo
19151       do k=1,3
19152         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19153              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19154              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19155         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19156              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19157              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19158       enddo
19159 !grad      do k=i,j-1
19160 !grad        do l=1,3
19161 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19162 !grad        enddo
19163 !grad      enddo
19164
19165       do l=1,3
19166         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19167         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19168       enddo
19169
19170       return
19171       end subroutine dyn_ssbond_ene
19172 !--------------------------------------------------------------------------
19173          subroutine triple_ssbond_ene(resi,resj,resk,eij)
19174 !      implicit none
19175 !      Includes
19176       use calc_data
19177       use comm_sschecks
19178 !      include 'DIMENSIONS'
19179 !      include 'COMMON.SBRIDGE'
19180 !      include 'COMMON.CHAIN'
19181 !      include 'COMMON.DERIV'
19182 !      include 'COMMON.LOCAL'
19183 !      include 'COMMON.INTERACT'
19184 !      include 'COMMON.VAR'
19185 !      include 'COMMON.IOUNITS'
19186 !      include 'COMMON.CALC'
19187 #ifndef CLUST
19188 #ifndef WHAM
19189        use MD_data
19190 !      include 'COMMON.MD'
19191 !      use MD, only: totT,t_bath
19192 #endif
19193 #endif
19194       double precision h_base
19195       external h_base
19196
19197 !c     Input arguments
19198       integer resi,resj,resk,m,itypi,itypj,itypk
19199
19200 !c     Output arguments
19201       double precision eij,eij1,eij2,eij3
19202
19203 !c     Local variables
19204       logical havebond
19205 !c      integer itypi,itypj,k,l
19206       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19207       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19208       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19209       double precision sig0ij,ljd,sig,fac,e1,e2
19210       double precision dcosom1(3),dcosom2(3),ed
19211       double precision pom1,pom2
19212       double precision ljA,ljB,ljXs
19213       double precision d_ljB(1:3)
19214       double precision ssA,ssB,ssC,ssXs
19215       double precision ssxm,ljxm,ssm,ljm
19216       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19217       eij=0.0
19218       if (dtriss.eq.0) return
19219       i=resi
19220       j=resj
19221       k=resk
19222 !C      write(iout,*) resi,resj,resk
19223       itypi=itype(i,1)
19224       dxi=dc_norm(1,nres+i)
19225       dyi=dc_norm(2,nres+i)
19226       dzi=dc_norm(3,nres+i)
19227       dsci_inv=vbld_inv(i+nres)
19228       xi=c(1,nres+i)
19229       yi=c(2,nres+i)
19230       zi=c(3,nres+i)
19231       itypj=itype(j,1)
19232       xj=c(1,nres+j)
19233       yj=c(2,nres+j)
19234       zj=c(3,nres+j)
19235
19236       dxj=dc_norm(1,nres+j)
19237       dyj=dc_norm(2,nres+j)
19238       dzj=dc_norm(3,nres+j)
19239       dscj_inv=vbld_inv(j+nres)
19240       itypk=itype(k,1)
19241       xk=c(1,nres+k)
19242       yk=c(2,nres+k)
19243       zk=c(3,nres+k)
19244
19245       dxk=dc_norm(1,nres+k)
19246       dyk=dc_norm(2,nres+k)
19247       dzk=dc_norm(3,nres+k)
19248       dscj_inv=vbld_inv(k+nres)
19249       xij=xj-xi
19250       xik=xk-xi
19251       xjk=xk-xj
19252       yij=yj-yi
19253       yik=yk-yi
19254       yjk=yk-yj
19255       zij=zj-zi
19256       zik=zk-zi
19257       zjk=zk-zj
19258       rrij=(xij*xij+yij*yij+zij*zij)
19259       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19260       rrik=(xik*xik+yik*yik+zik*zik)
19261       rik=dsqrt(rrik)
19262       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19263       rjk=dsqrt(rrjk)
19264 !C there are three combination of distances for each trisulfide bonds
19265 !C The first case the ith atom is the center
19266 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19267 !C distance y is second distance the a,b,c,d are parameters derived for
19268 !C this problem d parameter was set as a penalty currenlty set to 1.
19269       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19270       eij1=0.0d0
19271       else
19272       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19273       endif
19274 !C second case jth atom is center
19275       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19276       eij2=0.0d0
19277       else
19278       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19279       endif
19280 !C the third case kth atom is the center
19281       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19282       eij3=0.0d0
19283       else
19284       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19285       endif
19286 !C      eij2=0.0
19287 !C      eij3=0.0
19288 !C      eij1=0.0
19289       eij=eij1+eij2+eij3
19290 !C      write(iout,*)i,j,k,eij
19291 !C The energy penalty calculated now time for the gradient part
19292 !C derivative over rij
19293       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19294       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19295             gg(1)=xij*fac/rij
19296             gg(2)=yij*fac/rij
19297             gg(3)=zij*fac/rij
19298       do m=1,3
19299         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19300         gvdwx(m,j)=gvdwx(m,j)+gg(m)
19301       enddo
19302
19303       do l=1,3
19304         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19305         gvdwc(l,j)=gvdwc(l,j)+gg(l)
19306       enddo
19307 !C now derivative over rik
19308       fac=-eij1**2/dtriss* &
19309       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19310       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19311             gg(1)=xik*fac/rik
19312             gg(2)=yik*fac/rik
19313             gg(3)=zik*fac/rik
19314       do m=1,3
19315         gvdwx(m,i)=gvdwx(m,i)-gg(m)
19316         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19317       enddo
19318       do l=1,3
19319         gvdwc(l,i)=gvdwc(l,i)-gg(l)
19320         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19321       enddo
19322 !C now derivative over rjk
19323       fac=-eij2**2/dtriss* &
19324       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19325       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19326             gg(1)=xjk*fac/rjk
19327             gg(2)=yjk*fac/rjk
19328             gg(3)=zjk*fac/rjk
19329       do m=1,3
19330         gvdwx(m,j)=gvdwx(m,j)-gg(m)
19331         gvdwx(m,k)=gvdwx(m,k)+gg(m)
19332       enddo
19333       do l=1,3
19334         gvdwc(l,j)=gvdwc(l,j)-gg(l)
19335         gvdwc(l,k)=gvdwc(l,k)+gg(l)
19336       enddo
19337       return
19338       end subroutine triple_ssbond_ene
19339
19340
19341
19342 !-----------------------------------------------------------------------------
19343       real(kind=8) function h_base(x,deriv)
19344 !     A smooth function going 0->1 in range [0,1]
19345 !     It should NOT be called outside range [0,1], it will not work there.
19346       implicit none
19347
19348 !     Input arguments
19349       real(kind=8) :: x
19350
19351 !     Output arguments
19352       real(kind=8) :: deriv
19353
19354 !     Local variables
19355       real(kind=8) :: xsq
19356
19357
19358 !     Two parabolas put together.  First derivative zero at extrema
19359 !$$$      if (x.lt.0.5D0) then
19360 !$$$        h_base=2.0D0*x*x
19361 !$$$        deriv=4.0D0*x
19362 !$$$      else
19363 !$$$        deriv=1.0D0-x
19364 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19365 !$$$        deriv=4.0D0*deriv
19366 !$$$      endif
19367
19368 !     Third degree polynomial.  First derivative zero at extrema
19369       h_base=x*x*(3.0d0-2.0d0*x)
19370       deriv=6.0d0*x*(1.0d0-x)
19371
19372 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19373 !$$$      xsq=x*x
19374 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19375 !$$$      deriv=x-1.0d0
19376 !$$$      deriv=deriv*deriv
19377 !$$$      deriv=30.0d0*xsq*deriv
19378
19379       return
19380       end function h_base
19381 !-----------------------------------------------------------------------------
19382       subroutine dyn_set_nss
19383 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19384 !      implicit none
19385       use MD_data, only: totT,t_bath
19386 !     Includes
19387 !      include 'DIMENSIONS'
19388 #ifdef MPI
19389       include "mpif.h"
19390 #endif
19391 !      include 'COMMON.SBRIDGE'
19392 !      include 'COMMON.CHAIN'
19393 !      include 'COMMON.IOUNITS'
19394 !      include 'COMMON.SETUP'
19395 !      include 'COMMON.MD'
19396 !     Local variables
19397       real(kind=8) :: emin
19398       integer :: i,j,imin,ierr
19399       integer :: diff,allnss,newnss
19400       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19401                 newihpb,newjhpb
19402       logical :: found
19403       integer,dimension(0:nfgtasks) :: i_newnss
19404       integer,dimension(0:nfgtasks) :: displ
19405       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19406       integer :: g_newnss
19407
19408       allnss=0
19409       do i=1,nres-1
19410         do j=i+1,nres
19411           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19412             allnss=allnss+1
19413             allflag(allnss)=0
19414             allihpb(allnss)=i
19415             alljhpb(allnss)=j
19416           endif
19417         enddo
19418       enddo
19419
19420 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19421
19422  1    emin=1.0d300
19423       do i=1,allnss
19424         if (allflag(i).eq.0 .and. &
19425              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19426           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19427           imin=i
19428         endif
19429       enddo
19430       if (emin.lt.1.0d300) then
19431         allflag(imin)=1
19432         do i=1,allnss
19433           if (allflag(i).eq.0 .and. &
19434                (allihpb(i).eq.allihpb(imin) .or. &
19435                alljhpb(i).eq.allihpb(imin) .or. &
19436                allihpb(i).eq.alljhpb(imin) .or. &
19437                alljhpb(i).eq.alljhpb(imin))) then
19438             allflag(i)=-1
19439           endif
19440         enddo
19441         goto 1
19442       endif
19443
19444 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19445
19446       newnss=0
19447       do i=1,allnss
19448         if (allflag(i).eq.1) then
19449           newnss=newnss+1
19450           newihpb(newnss)=allihpb(i)
19451           newjhpb(newnss)=alljhpb(i)
19452         endif
19453       enddo
19454
19455 #ifdef MPI
19456       if (nfgtasks.gt.1)then
19457
19458         call MPI_Reduce(newnss,g_newnss,1,&
19459           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19460         call MPI_Gather(newnss,1,MPI_INTEGER,&
19461                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19462         displ(0)=0
19463         do i=1,nfgtasks-1,1
19464           displ(i)=i_newnss(i-1)+displ(i-1)
19465         enddo
19466         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19467                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
19468                          king,FG_COMM,IERR)
19469         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19470                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19471                          king,FG_COMM,IERR)
19472         if(fg_rank.eq.0) then
19473 !         print *,'g_newnss',g_newnss
19474 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19475 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19476          newnss=g_newnss
19477          do i=1,newnss
19478           newihpb(i)=g_newihpb(i)
19479           newjhpb(i)=g_newjhpb(i)
19480          enddo
19481         endif
19482       endif
19483 #endif
19484
19485       diff=newnss-nss
19486
19487 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19488 !       print *,newnss,nss,maxdim
19489       do i=1,nss
19490         found=.false.
19491 !        print *,newnss
19492         do j=1,newnss
19493 !!          print *,j
19494           if (idssb(i).eq.newihpb(j) .and. &
19495                jdssb(i).eq.newjhpb(j)) found=.true.
19496         enddo
19497 #ifndef CLUST
19498 #ifndef WHAM
19499 !        write(iout,*) "found",found,i,j
19500         if (.not.found.and.fg_rank.eq.0) &
19501             write(iout,'(a15,f12.2,f8.1,2i5)') &
19502              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19503 #endif
19504 #endif
19505       enddo
19506
19507       do i=1,newnss
19508         found=.false.
19509         do j=1,nss
19510 !          print *,i,j
19511           if (newihpb(i).eq.idssb(j) .and. &
19512                newjhpb(i).eq.jdssb(j)) found=.true.
19513         enddo
19514 #ifndef CLUST
19515 #ifndef WHAM
19516 !        write(iout,*) "found",found,i,j
19517         if (.not.found.and.fg_rank.eq.0) &
19518             write(iout,'(a15,f12.2,f8.1,2i5)') &
19519              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19520 #endif
19521 #endif
19522       enddo
19523
19524       nss=newnss
19525       do i=1,nss
19526         idssb(i)=newihpb(i)
19527         jdssb(i)=newjhpb(i)
19528       enddo
19529
19530       return
19531       end subroutine dyn_set_nss
19532 ! Lipid transfer energy function
19533       subroutine Eliptransfer(eliptran)
19534 !C this is done by Adasko
19535 !C      print *,"wchodze"
19536 !C structure of box:
19537 !C      water
19538 !C--bordliptop-- buffore starts
19539 !C--bufliptop--- here true lipid starts
19540 !C      lipid
19541 !C--buflipbot--- lipid ends buffore starts
19542 !C--bordlipbot--buffore ends
19543       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19544       integer :: i
19545       eliptran=0.0
19546 !      print *, "I am in eliptran"
19547       do i=ilip_start,ilip_end
19548 !C       do i=1,1
19549         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19550          cycle
19551
19552         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19553         if (positi.le.0.0) positi=positi+boxzsize
19554 !C        print *,i
19555 !C first for peptide groups
19556 !c for each residue check if it is in lipid or lipid water border area
19557        if ((positi.gt.bordlipbot)  &
19558       .and.(positi.lt.bordliptop)) then
19559 !C the energy transfer exist
19560         if (positi.lt.buflipbot) then
19561 !C what fraction I am in
19562          fracinbuf=1.0d0-      &
19563              ((positi-bordlipbot)/lipbufthick)
19564 !C lipbufthick is thickenes of lipid buffore
19565          sslip=sscalelip(fracinbuf)
19566          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19567          eliptran=eliptran+sslip*pepliptran
19568          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19569          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19570 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19571
19572 !C        print *,"doing sccale for lower part"
19573 !C         print *,i,sslip,fracinbuf,ssgradlip
19574         elseif (positi.gt.bufliptop) then
19575          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19576          sslip=sscalelip(fracinbuf)
19577          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19578          eliptran=eliptran+sslip*pepliptran
19579          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19580          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19581 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19582 !C          print *, "doing sscalefor top part"
19583 !C         print *,i,sslip,fracinbuf,ssgradlip
19584         else
19585          eliptran=eliptran+pepliptran
19586 !C         print *,"I am in true lipid"
19587         endif
19588 !C       else
19589 !C       eliptran=elpitran+0.0 ! I am in water
19590        endif
19591        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19592        enddo
19593 ! here starts the side chain transfer
19594        do i=ilip_start,ilip_end
19595         if (itype(i,1).eq.ntyp1) cycle
19596         positi=(mod(c(3,i+nres),boxzsize))
19597         if (positi.le.0) positi=positi+boxzsize
19598 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19599 !c for each residue check if it is in lipid or lipid water border area
19600 !C       respos=mod(c(3,i+nres),boxzsize)
19601 !C       print *,positi,bordlipbot,buflipbot
19602        if ((positi.gt.bordlipbot) &
19603        .and.(positi.lt.bordliptop)) then
19604 !C the energy transfer exist
19605         if (positi.lt.buflipbot) then
19606          fracinbuf=1.0d0-   &
19607            ((positi-bordlipbot)/lipbufthick)
19608 !C lipbufthick is thickenes of lipid buffore
19609          sslip=sscalelip(fracinbuf)
19610          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19611          eliptran=eliptran+sslip*liptranene(itype(i,1))
19612          gliptranx(3,i)=gliptranx(3,i) &
19613       +ssgradlip*liptranene(itype(i,1))
19614          gliptranc(3,i-1)= gliptranc(3,i-1) &
19615       +ssgradlip*liptranene(itype(i,1))
19616 !C         print *,"doing sccale for lower part"
19617         elseif (positi.gt.bufliptop) then
19618          fracinbuf=1.0d0-  &
19619       ((bordliptop-positi)/lipbufthick)
19620          sslip=sscalelip(fracinbuf)
19621          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19622          eliptran=eliptran+sslip*liptranene(itype(i,1))
19623          gliptranx(3,i)=gliptranx(3,i)  &
19624        +ssgradlip*liptranene(itype(i,1))
19625          gliptranc(3,i-1)= gliptranc(3,i-1) &
19626       +ssgradlip*liptranene(itype(i,1))
19627 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19628         else
19629          eliptran=eliptran+liptranene(itype(i,1))
19630 !C         print *,"I am in true lipid"
19631         endif
19632         endif ! if in lipid or buffor
19633 !C       else
19634 !C       eliptran=elpitran+0.0 ! I am in water
19635         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19636        enddo
19637        return
19638        end  subroutine Eliptransfer
19639 !----------------------------------NANO FUNCTIONS
19640 !C-----------------------------------------------------------------------
19641 !C-----------------------------------------------------------
19642 !C This subroutine is to mimic the histone like structure but as well can be
19643 !C utilizet to nanostructures (infinit) small modification has to be used to
19644 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19645 !C gradient has to be modified at the ends
19646 !C The energy function is Kihara potential
19647 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19648 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19649 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19650 !C simple Kihara potential
19651       subroutine calctube(Etube)
19652       real(kind=8),dimension(3) :: vectube
19653       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19654        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19655        sc_aa_tube,sc_bb_tube
19656       integer :: i,j,iti
19657       Etube=0.0d0
19658       do i=itube_start,itube_end
19659         enetube(i)=0.0d0
19660         enetube(i+nres)=0.0d0
19661       enddo
19662 !C first we calculate the distance from tube center
19663 !C for UNRES
19664        do i=itube_start,itube_end
19665 !C lets ommit dummy atoms for now
19666        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19667 !C now calculate distance from center of tube and direction vectors
19668       xmin=boxxsize
19669       ymin=boxysize
19670 ! Find minimum distance in periodic box
19671         do j=-1,1
19672          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19673          vectube(1)=vectube(1)+boxxsize*j
19674          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19675          vectube(2)=vectube(2)+boxysize*j
19676          xminact=abs(vectube(1)-tubecenter(1))
19677          yminact=abs(vectube(2)-tubecenter(2))
19678            if (xmin.gt.xminact) then
19679             xmin=xminact
19680             xtemp=vectube(1)
19681            endif
19682            if (ymin.gt.yminact) then
19683              ymin=yminact
19684              ytemp=vectube(2)
19685             endif
19686          enddo
19687       vectube(1)=xtemp
19688       vectube(2)=ytemp
19689       vectube(1)=vectube(1)-tubecenter(1)
19690       vectube(2)=vectube(2)-tubecenter(2)
19691
19692 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19693 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19694
19695 !C as the tube is infinity we do not calculate the Z-vector use of Z
19696 !C as chosen axis
19697       vectube(3)=0.0d0
19698 !C now calculte the distance
19699        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19700 !C now normalize vector
19701       vectube(1)=vectube(1)/tub_r
19702       vectube(2)=vectube(2)/tub_r
19703 !C calculte rdiffrence between r and r0
19704       rdiff=tub_r-tubeR0
19705 !C and its 6 power
19706       rdiff6=rdiff**6.0d0
19707 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19708        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19709 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19710 !C       print *,rdiff,rdiff6,pep_aa_tube
19711 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19712 !C now we calculate gradient
19713        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19714             6.0d0*pep_bb_tube)/rdiff6/rdiff
19715 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19716 !C     &rdiff,fac
19717 !C now direction of gg_tube vector
19718         do j=1,3
19719         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19720         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19721         enddo
19722         enddo
19723 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19724 !C        print *,gg_tube(1,0),"TU"
19725
19726
19727        do i=itube_start,itube_end
19728 !C Lets not jump over memory as we use many times iti
19729          iti=itype(i,1)
19730 !C lets ommit dummy atoms for now
19731          if ((iti.eq.ntyp1)  &
19732 !C in UNRES uncomment the line below as GLY has no side-chain...
19733 !C      .or.(iti.eq.10)
19734         ) cycle
19735       xmin=boxxsize
19736       ymin=boxysize
19737         do j=-1,1
19738          vectube(1)=mod((c(1,i+nres)),boxxsize)
19739          vectube(1)=vectube(1)+boxxsize*j
19740          vectube(2)=mod((c(2,i+nres)),boxysize)
19741          vectube(2)=vectube(2)+boxysize*j
19742
19743          xminact=abs(vectube(1)-tubecenter(1))
19744          yminact=abs(vectube(2)-tubecenter(2))
19745            if (xmin.gt.xminact) then
19746             xmin=xminact
19747             xtemp=vectube(1)
19748            endif
19749            if (ymin.gt.yminact) then
19750              ymin=yminact
19751              ytemp=vectube(2)
19752             endif
19753          enddo
19754       vectube(1)=xtemp
19755       vectube(2)=ytemp
19756 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19757 !C     &     tubecenter(2)
19758       vectube(1)=vectube(1)-tubecenter(1)
19759       vectube(2)=vectube(2)-tubecenter(2)
19760
19761 !C as the tube is infinity we do not calculate the Z-vector use of Z
19762 !C as chosen axis
19763       vectube(3)=0.0d0
19764 !C now calculte the distance
19765        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19766 !C now normalize vector
19767       vectube(1)=vectube(1)/tub_r
19768       vectube(2)=vectube(2)/tub_r
19769
19770 !C calculte rdiffrence between r and r0
19771       rdiff=tub_r-tubeR0
19772 !C and its 6 power
19773       rdiff6=rdiff**6.0d0
19774 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19775        sc_aa_tube=sc_aa_tube_par(iti)
19776        sc_bb_tube=sc_bb_tube_par(iti)
19777        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19778        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19779              6.0d0*sc_bb_tube/rdiff6/rdiff
19780 !C now direction of gg_tube vector
19781          do j=1,3
19782           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19783           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19784          enddo
19785         enddo
19786         do i=itube_start,itube_end
19787           Etube=Etube+enetube(i)+enetube(i+nres)
19788         enddo
19789 !C        print *,"ETUBE", etube
19790         return
19791         end subroutine calctube
19792 !C TO DO 1) add to total energy
19793 !C       2) add to gradient summation
19794 !C       3) add reading parameters (AND of course oppening of PARAM file)
19795 !C       4) add reading the center of tube
19796 !C       5) add COMMONs
19797 !C       6) add to zerograd
19798 !C       7) allocate matrices
19799
19800
19801 !C-----------------------------------------------------------------------
19802 !C-----------------------------------------------------------
19803 !C This subroutine is to mimic the histone like structure but as well can be
19804 !C utilizet to nanostructures (infinit) small modification has to be used to
19805 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19806 !C gradient has to be modified at the ends
19807 !C The energy function is Kihara potential
19808 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19809 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19810 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19811 !C simple Kihara potential
19812       subroutine calctube2(Etube)
19813             real(kind=8),dimension(3) :: vectube
19814       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19815        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19816        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19817       integer:: i,j,iti
19818       Etube=0.0d0
19819       do i=itube_start,itube_end
19820         enetube(i)=0.0d0
19821         enetube(i+nres)=0.0d0
19822       enddo
19823 !C first we calculate the distance from tube center
19824 !C first sugare-phosphate group for NARES this would be peptide group
19825 !C for UNRES
19826        do i=itube_start,itube_end
19827 !C lets ommit dummy atoms for now
19828
19829        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19830 !C now calculate distance from center of tube and direction vectors
19831 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19832 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19833 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19834 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19835       xmin=boxxsize
19836       ymin=boxysize
19837         do j=-1,1
19838          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19839          vectube(1)=vectube(1)+boxxsize*j
19840          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19841          vectube(2)=vectube(2)+boxysize*j
19842
19843          xminact=abs(vectube(1)-tubecenter(1))
19844          yminact=abs(vectube(2)-tubecenter(2))
19845            if (xmin.gt.xminact) then
19846             xmin=xminact
19847             xtemp=vectube(1)
19848            endif
19849            if (ymin.gt.yminact) then
19850              ymin=yminact
19851              ytemp=vectube(2)
19852             endif
19853          enddo
19854       vectube(1)=xtemp
19855       vectube(2)=ytemp
19856       vectube(1)=vectube(1)-tubecenter(1)
19857       vectube(2)=vectube(2)-tubecenter(2)
19858
19859 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19860 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19861
19862 !C as the tube is infinity we do not calculate the Z-vector use of Z
19863 !C as chosen axis
19864       vectube(3)=0.0d0
19865 !C now calculte the distance
19866        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19867 !C now normalize vector
19868       vectube(1)=vectube(1)/tub_r
19869       vectube(2)=vectube(2)/tub_r
19870 !C calculte rdiffrence between r and r0
19871       rdiff=tub_r-tubeR0
19872 !C and its 6 power
19873       rdiff6=rdiff**6.0d0
19874 !C THIS FRAGMENT MAKES TUBE FINITE
19875         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19876         if (positi.le.0) positi=positi+boxzsize
19877 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19878 !c for each residue check if it is in lipid or lipid water border area
19879 !C       respos=mod(c(3,i+nres),boxzsize)
19880 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19881        if ((positi.gt.bordtubebot)  &
19882         .and.(positi.lt.bordtubetop)) then
19883 !C the energy transfer exist
19884         if (positi.lt.buftubebot) then
19885          fracinbuf=1.0d0-  &
19886            ((positi-bordtubebot)/tubebufthick)
19887 !C lipbufthick is thickenes of lipid buffore
19888          sstube=sscalelip(fracinbuf)
19889          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19890 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19891          enetube(i)=enetube(i)+sstube*tubetranenepep
19892 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19893 !C     &+ssgradtube*tubetranene(itype(i,1))
19894 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19895 !C     &+ssgradtube*tubetranene(itype(i,1))
19896 !C         print *,"doing sccale for lower part"
19897         elseif (positi.gt.buftubetop) then
19898          fracinbuf=1.0d0-  &
19899         ((bordtubetop-positi)/tubebufthick)
19900          sstube=sscalelip(fracinbuf)
19901          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19902          enetube(i)=enetube(i)+sstube*tubetranenepep
19903 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19904 !C     &+ssgradtube*tubetranene(itype(i,1))
19905 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19906 !C     &+ssgradtube*tubetranene(itype(i,1))
19907 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19908         else
19909          sstube=1.0d0
19910          ssgradtube=0.0d0
19911          enetube(i)=enetube(i)+sstube*tubetranenepep
19912 !C         print *,"I am in true lipid"
19913         endif
19914         else
19915 !C          sstube=0.0d0
19916 !C          ssgradtube=0.0d0
19917         cycle
19918         endif ! if in lipid or buffor
19919
19920 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19921        enetube(i)=enetube(i)+sstube* &
19922         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19923 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19924 !C       print *,rdiff,rdiff6,pep_aa_tube
19925 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19926 !C now we calculate gradient
19927        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19928              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19929 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19930 !C     &rdiff,fac
19931
19932 !C now direction of gg_tube vector
19933        do j=1,3
19934         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19935         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19936         enddo
19937          gg_tube(3,i)=gg_tube(3,i)  &
19938        +ssgradtube*enetube(i)/sstube/2.0d0
19939          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19940        +ssgradtube*enetube(i)/sstube/2.0d0
19941
19942         enddo
19943 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19944 !C        print *,gg_tube(1,0),"TU"
19945         do i=itube_start,itube_end
19946 !C Lets not jump over memory as we use many times iti
19947          iti=itype(i,1)
19948 !C lets ommit dummy atoms for now
19949          if ((iti.eq.ntyp1) &
19950 !!C in UNRES uncomment the line below as GLY has no side-chain...
19951            .or.(iti.eq.10) &
19952           ) cycle
19953           vectube(1)=c(1,i+nres)
19954           vectube(1)=mod(vectube(1),boxxsize)
19955           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19956           vectube(2)=c(2,i+nres)
19957           vectube(2)=mod(vectube(2),boxysize)
19958           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19959
19960       vectube(1)=vectube(1)-tubecenter(1)
19961       vectube(2)=vectube(2)-tubecenter(2)
19962 !C THIS FRAGMENT MAKES TUBE FINITE
19963         positi=(mod(c(3,i+nres),boxzsize))
19964         if (positi.le.0) positi=positi+boxzsize
19965 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19966 !c for each residue check if it is in lipid or lipid water border area
19967 !C       respos=mod(c(3,i+nres),boxzsize)
19968 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19969
19970        if ((positi.gt.bordtubebot)  &
19971         .and.(positi.lt.bordtubetop)) then
19972 !C the energy transfer exist
19973         if (positi.lt.buftubebot) then
19974          fracinbuf=1.0d0- &
19975             ((positi-bordtubebot)/tubebufthick)
19976 !C lipbufthick is thickenes of lipid buffore
19977          sstube=sscalelip(fracinbuf)
19978          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19979 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19980          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19981 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19982 !C     &+ssgradtube*tubetranene(itype(i,1))
19983 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19984 !C     &+ssgradtube*tubetranene(itype(i,1))
19985 !C         print *,"doing sccale for lower part"
19986         elseif (positi.gt.buftubetop) then
19987          fracinbuf=1.0d0- &
19988         ((bordtubetop-positi)/tubebufthick)
19989
19990          sstube=sscalelip(fracinbuf)
19991          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19992          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19993 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19994 !C     &+ssgradtube*tubetranene(itype(i,1))
19995 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19996 !C     &+ssgradtube*tubetranene(itype(i,1))
19997 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19998         else
19999          sstube=1.0d0
20000          ssgradtube=0.0d0
20001          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20002 !C         print *,"I am in true lipid"
20003         endif
20004         else
20005 !C          sstube=0.0d0
20006 !C          ssgradtube=0.0d0
20007         cycle
20008         endif ! if in lipid or buffor
20009 !CEND OF FINITE FRAGMENT
20010 !C as the tube is infinity we do not calculate the Z-vector use of Z
20011 !C as chosen axis
20012       vectube(3)=0.0d0
20013 !C now calculte the distance
20014        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20015 !C now normalize vector
20016       vectube(1)=vectube(1)/tub_r
20017       vectube(2)=vectube(2)/tub_r
20018 !C calculte rdiffrence between r and r0
20019       rdiff=tub_r-tubeR0
20020 !C and its 6 power
20021       rdiff6=rdiff**6.0d0
20022 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20023        sc_aa_tube=sc_aa_tube_par(iti)
20024        sc_bb_tube=sc_bb_tube_par(iti)
20025        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20026                        *sstube+enetube(i+nres)
20027 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20028 !C now we calculate gradient
20029        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20030             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20031 !C now direction of gg_tube vector
20032          do j=1,3
20033           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20034           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20035          enddo
20036          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20037        +ssgradtube*enetube(i+nres)/sstube
20038          gg_tube(3,i-1)= gg_tube(3,i-1) &
20039        +ssgradtube*enetube(i+nres)/sstube
20040
20041         enddo
20042         do i=itube_start,itube_end
20043           Etube=Etube+enetube(i)+enetube(i+nres)
20044         enddo
20045 !C        print *,"ETUBE", etube
20046         return
20047         end subroutine calctube2
20048 !=====================================================================================================================================
20049       subroutine calcnano(Etube)
20050       real(kind=8),dimension(3) :: vectube
20051
20052       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20053        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20054        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
20055        integer:: i,j,iti,r
20056
20057       Etube=0.0d0
20058 !      print *,itube_start,itube_end,"poczatek"
20059       do i=itube_start,itube_end
20060         enetube(i)=0.0d0
20061         enetube(i+nres)=0.0d0
20062       enddo
20063 !C first we calculate the distance from tube center
20064 !C first sugare-phosphate group for NARES this would be peptide group
20065 !C for UNRES
20066        do i=itube_start,itube_end
20067 !C lets ommit dummy atoms for now
20068        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20069 !C now calculate distance from center of tube and direction vectors
20070       xmin=boxxsize
20071       ymin=boxysize
20072       zmin=boxzsize
20073
20074         do j=-1,1
20075          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20076          vectube(1)=vectube(1)+boxxsize*j
20077          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20078          vectube(2)=vectube(2)+boxysize*j
20079          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20080          vectube(3)=vectube(3)+boxzsize*j
20081
20082
20083          xminact=dabs(vectube(1)-tubecenter(1))
20084          yminact=dabs(vectube(2)-tubecenter(2))
20085          zminact=dabs(vectube(3)-tubecenter(3))
20086
20087            if (xmin.gt.xminact) then
20088             xmin=xminact
20089             xtemp=vectube(1)
20090            endif
20091            if (ymin.gt.yminact) then
20092              ymin=yminact
20093              ytemp=vectube(2)
20094             endif
20095            if (zmin.gt.zminact) then
20096              zmin=zminact
20097              ztemp=vectube(3)
20098             endif
20099          enddo
20100       vectube(1)=xtemp
20101       vectube(2)=ytemp
20102       vectube(3)=ztemp
20103
20104       vectube(1)=vectube(1)-tubecenter(1)
20105       vectube(2)=vectube(2)-tubecenter(2)
20106       vectube(3)=vectube(3)-tubecenter(3)
20107
20108 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20109 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20110 !C as the tube is infinity we do not calculate the Z-vector use of Z
20111 !C as chosen axis
20112 !C      vectube(3)=0.0d0
20113 !C now calculte the distance
20114        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20115 !C now normalize vector
20116       vectube(1)=vectube(1)/tub_r
20117       vectube(2)=vectube(2)/tub_r
20118       vectube(3)=vectube(3)/tub_r
20119 !C calculte rdiffrence between r and r0
20120       rdiff=tub_r-tubeR0
20121 !C and its 6 power
20122       rdiff6=rdiff**6.0d0
20123 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20124        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20125 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20126 !C       print *,rdiff,rdiff6,pep_aa_tube
20127 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20128 !C now we calculate gradient
20129        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20130             6.0d0*pep_bb_tube)/rdiff6/rdiff
20131 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20132 !C     &rdiff,fac
20133          if (acavtubpep.eq.0.0d0) then
20134 !C go to 667
20135          enecavtube(i)=0.0
20136          faccav=0.0
20137          else
20138          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20139          enecavtube(i)=  &
20140         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20141         /denominator
20142          enecavtube(i)=0.0
20143          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20144         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20145         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20146         /denominator**2.0d0
20147 !C         faccav=0.0
20148 !C         fac=fac+faccav
20149 !C 667     continue
20150          endif
20151           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20152         do j=1,3
20153         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20154         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20155         enddo
20156         enddo
20157
20158        do i=itube_start,itube_end
20159         enecavtube(i)=0.0d0
20160 !C Lets not jump over memory as we use many times iti
20161          iti=itype(i,1)
20162 !C lets ommit dummy atoms for now
20163          if ((iti.eq.ntyp1) &
20164 !C in UNRES uncomment the line below as GLY has no side-chain...
20165 !C      .or.(iti.eq.10)
20166          ) cycle
20167       xmin=boxxsize
20168       ymin=boxysize
20169       zmin=boxzsize
20170         do j=-1,1
20171          vectube(1)=dmod((c(1,i+nres)),boxxsize)
20172          vectube(1)=vectube(1)+boxxsize*j
20173          vectube(2)=dmod((c(2,i+nres)),boxysize)
20174          vectube(2)=vectube(2)+boxysize*j
20175          vectube(3)=dmod((c(3,i+nres)),boxzsize)
20176          vectube(3)=vectube(3)+boxzsize*j
20177
20178
20179          xminact=dabs(vectube(1)-tubecenter(1))
20180          yminact=dabs(vectube(2)-tubecenter(2))
20181          zminact=dabs(vectube(3)-tubecenter(3))
20182
20183            if (xmin.gt.xminact) then
20184             xmin=xminact
20185             xtemp=vectube(1)
20186            endif
20187            if (ymin.gt.yminact) then
20188              ymin=yminact
20189              ytemp=vectube(2)
20190             endif
20191            if (zmin.gt.zminact) then
20192              zmin=zminact
20193              ztemp=vectube(3)
20194             endif
20195          enddo
20196       vectube(1)=xtemp
20197       vectube(2)=ytemp
20198       vectube(3)=ztemp
20199
20200 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20201 !C     &     tubecenter(2)
20202       vectube(1)=vectube(1)-tubecenter(1)
20203       vectube(2)=vectube(2)-tubecenter(2)
20204       vectube(3)=vectube(3)-tubecenter(3)
20205 !C now calculte the distance
20206        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20207 !C now normalize vector
20208       vectube(1)=vectube(1)/tub_r
20209       vectube(2)=vectube(2)/tub_r
20210       vectube(3)=vectube(3)/tub_r
20211
20212 !C calculte rdiffrence between r and r0
20213       rdiff=tub_r-tubeR0
20214 !C and its 6 power
20215       rdiff6=rdiff**6.0d0
20216        sc_aa_tube=sc_aa_tube_par(iti)
20217        sc_bb_tube=sc_bb_tube_par(iti)
20218        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20219 !C       enetube(i+nres)=0.0d0
20220 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20221 !C now we calculate gradient
20222        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20223             6.0d0*sc_bb_tube/rdiff6/rdiff
20224 !C       fac=0.0
20225 !C now direction of gg_tube vector
20226 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20227          if (acavtub(iti).eq.0.0d0) then
20228 !C go to 667
20229          enecavtube(i+nres)=0.0d0
20230          faccav=0.0d0
20231          else
20232          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20233          enecavtube(i+nres)=   &
20234         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20235         /denominator
20236 !C         enecavtube(i)=0.0
20237          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20238         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20239         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20240         /denominator**2.0d0
20241 !C         faccav=0.0
20242          fac=fac+faccav
20243 !C 667     continue
20244          endif
20245 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20246 !C     &   enecavtube(i),faccav
20247 !C         print *,"licz=",
20248 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20249 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20250          do j=1,3
20251           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20252           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20253          enddo
20254           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20255         enddo
20256
20257
20258
20259         do i=itube_start,itube_end
20260           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20261          +enecavtube(i+nres)
20262         enddo
20263 !        do i=1,20
20264 !         print *,"begin", i,"a"
20265 !         do r=1,10000
20266 !          rdiff=r/100.0d0
20267 !          rdiff6=rdiff**6.0d0
20268 !          sc_aa_tube=sc_aa_tube_par(i)
20269 !          sc_bb_tube=sc_bb_tube_par(i)
20270 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20271 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20272 !          enecavtube(i)=   &
20273 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20274 !         /denominator
20275
20276 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20277 !         enddo
20278 !         print *,"end",i,"a"
20279 !        enddo
20280 !C        print *,"ETUBE", etube
20281         return
20282         end subroutine calcnano
20283
20284 !===============================================
20285 !--------------------------------------------------------------------------------
20286 !C first for shielding is setting of function of side-chains
20287
20288        subroutine set_shield_fac2
20289        real(kind=8) :: div77_81=0.974996043d0, &
20290         div4_81=0.2222222222d0
20291        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20292          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20293          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20294          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20295 !C the vector between center of side_chain and peptide group
20296        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20297          pept_group,costhet_grad,cosphi_grad_long, &
20298          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20299          sh_frac_dist_grad,pep_side
20300         integer i,j,k
20301 !C      write(2,*) "ivec",ivec_start,ivec_end
20302       do i=1,nres
20303         fac_shield(i)=0.0d0
20304         ishield_list(i)=0
20305         do j=1,3
20306         grad_shield(j,i)=0.0d0
20307         enddo
20308       enddo
20309       do i=ivec_start,ivec_end
20310 !C      do i=1,nres-1
20311 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20312 !      ishield_list(i)=0
20313       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20314 !Cif there two consequtive dummy atoms there is no peptide group between them
20315 !C the line below has to be changed for FGPROC>1
20316       VolumeTotal=0.0
20317       do k=1,nres
20318        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20319        dist_pep_side=0.0
20320        dist_side_calf=0.0
20321        do j=1,3
20322 !C first lets set vector conecting the ithe side-chain with kth side-chain
20323       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20324 !C      pep_side(j)=2.0d0
20325 !C and vector conecting the side-chain with its proper calfa
20326       side_calf(j)=c(j,k+nres)-c(j,k)
20327 !C      side_calf(j)=2.0d0
20328       pept_group(j)=c(j,i)-c(j,i+1)
20329 !C lets have their lenght
20330       dist_pep_side=pep_side(j)**2+dist_pep_side
20331       dist_side_calf=dist_side_calf+side_calf(j)**2
20332       dist_pept_group=dist_pept_group+pept_group(j)**2
20333       enddo
20334        dist_pep_side=sqrt(dist_pep_side)
20335        dist_pept_group=sqrt(dist_pept_group)
20336        dist_side_calf=sqrt(dist_side_calf)
20337       do j=1,3
20338         pep_side_norm(j)=pep_side(j)/dist_pep_side
20339         side_calf_norm(j)=dist_side_calf
20340       enddo
20341 !C now sscale fraction
20342        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20343 !       print *,buff_shield,"buff",sh_frac_dist
20344 !C now sscale
20345         if (sh_frac_dist.le.0.0) cycle
20346 !C        print *,ishield_list(i),i
20347 !C If we reach here it means that this side chain reaches the shielding sphere
20348 !C Lets add him to the list for gradient
20349         ishield_list(i)=ishield_list(i)+1
20350 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20351 !C this list is essential otherwise problem would be O3
20352         shield_list(ishield_list(i),i)=k
20353 !C Lets have the sscale value
20354         if (sh_frac_dist.gt.1.0) then
20355          scale_fac_dist=1.0d0
20356          do j=1,3
20357          sh_frac_dist_grad(j)=0.0d0
20358          enddo
20359         else
20360          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20361                         *(2.0d0*sh_frac_dist-3.0d0)
20362          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20363                        /dist_pep_side/buff_shield*0.5d0
20364          do j=1,3
20365          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20366 !C         sh_frac_dist_grad(j)=0.0d0
20367 !C         scale_fac_dist=1.0d0
20368 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20369 !C     &                    sh_frac_dist_grad(j)
20370          enddo
20371         endif
20372 !C this is what is now we have the distance scaling now volume...
20373       short=short_r_sidechain(itype(k,1))
20374       long=long_r_sidechain(itype(k,1))
20375       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20376       sinthet=short/dist_pep_side*costhet
20377 !      print *,"SORT",short,long,sinthet,costhet
20378 !C now costhet_grad
20379 !C       costhet=0.6d0
20380 !C       sinthet=0.8
20381        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20382 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20383 !C     &             -short/dist_pep_side**2/costhet)
20384 !C       costhet_fac=0.0d0
20385        do j=1,3
20386          costhet_grad(j)=costhet_fac*pep_side(j)
20387        enddo
20388 !C remember for the final gradient multiply costhet_grad(j)
20389 !C for side_chain by factor -2 !
20390 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20391 !C pep_side0pept_group is vector multiplication
20392       pep_side0pept_group=0.0d0
20393       do j=1,3
20394       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20395       enddo
20396       cosalfa=(pep_side0pept_group/ &
20397       (dist_pep_side*dist_side_calf))
20398       fac_alfa_sin=1.0d0-cosalfa**2
20399       fac_alfa_sin=dsqrt(fac_alfa_sin)
20400       rkprim=fac_alfa_sin*(long-short)+short
20401 !C      rkprim=short
20402
20403 !C now costhet_grad
20404        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20405 !C       cosphi=0.6
20406        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20407        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20408            dist_pep_side**2)
20409 !C       sinphi=0.8
20410        do j=1,3
20411          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20412       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20413       *(long-short)/fac_alfa_sin*cosalfa/ &
20414       ((dist_pep_side*dist_side_calf))* &
20415       ((side_calf(j))-cosalfa* &
20416       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20417 !C       cosphi_grad_long(j)=0.0d0
20418         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20419       *(long-short)/fac_alfa_sin*cosalfa &
20420       /((dist_pep_side*dist_side_calf))* &
20421       (pep_side(j)- &
20422       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20423 !C       cosphi_grad_loc(j)=0.0d0
20424        enddo
20425 !C      print *,sinphi,sinthet
20426       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20427                          /VSolvSphere_div
20428 !C     &                    *wshield
20429 !C now the gradient...
20430       do j=1,3
20431       grad_shield(j,i)=grad_shield(j,i) &
20432 !C gradient po skalowaniu
20433                      +(sh_frac_dist_grad(j)*VofOverlap &
20434 !C  gradient po costhet
20435             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20436         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20437             sinphi/sinthet*costhet*costhet_grad(j) &
20438            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20439         )*wshield
20440 !C grad_shield_side is Cbeta sidechain gradient
20441       grad_shield_side(j,ishield_list(i),i)=&
20442              (sh_frac_dist_grad(j)*-2.0d0&
20443              *VofOverlap&
20444             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20445        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20446             sinphi/sinthet*costhet*costhet_grad(j)&
20447            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20448             )*wshield
20449 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20450 !            sinphi/sinthet,&
20451 !           +sinthet/sinphi,"HERE"
20452        grad_shield_loc(j,ishield_list(i),i)=   &
20453             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20454       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20455             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20456              ))&
20457              *wshield
20458 !         print *,grad_shield_loc(j,ishield_list(i),i)
20459       enddo
20460       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20461       enddo
20462       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20463
20464 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20465       enddo
20466       return
20467       end subroutine set_shield_fac2
20468 !----------------------------------------------------------------------------
20469 ! SOUBROUTINE FOR AFM
20470        subroutine AFMvel(Eafmforce)
20471        use MD_data, only:totTafm
20472       real(kind=8),dimension(3) :: diffafm
20473       real(kind=8) :: afmdist,Eafmforce
20474        integer :: i
20475 !C Only for check grad COMMENT if not used for checkgrad
20476 !C      totT=3.0d0
20477 !C--------------------------------------------------------
20478 !C      print *,"wchodze"
20479       afmdist=0.0d0
20480       Eafmforce=0.0d0
20481       do i=1,3
20482       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20483       afmdist=afmdist+diffafm(i)**2
20484       enddo
20485       afmdist=dsqrt(afmdist)
20486 !      totTafm=3.0
20487       Eafmforce=0.5d0*forceAFMconst &
20488       *(distafminit+totTafm*velAFMconst-afmdist)**2
20489 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20490       do i=1,3
20491       gradafm(i,afmend-1)=-forceAFMconst* &
20492        (distafminit+totTafm*velAFMconst-afmdist) &
20493        *diffafm(i)/afmdist
20494       gradafm(i,afmbeg-1)=forceAFMconst* &
20495       (distafminit+totTafm*velAFMconst-afmdist) &
20496       *diffafm(i)/afmdist
20497       enddo
20498 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20499       return
20500       end subroutine AFMvel
20501 !---------------------------------------------------------
20502        subroutine AFMforce(Eafmforce)
20503
20504       real(kind=8),dimension(3) :: diffafm
20505 !      real(kind=8) ::afmdist
20506       real(kind=8) :: afmdist,Eafmforce
20507       integer :: i
20508       afmdist=0.0d0
20509       Eafmforce=0.0d0
20510       do i=1,3
20511       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20512       afmdist=afmdist+diffafm(i)**2
20513       enddo
20514       afmdist=dsqrt(afmdist)
20515 !      print *,afmdist,distafminit
20516       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20517       do i=1,3
20518       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20519       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20520       enddo
20521 !C      print *,'AFM',Eafmforce
20522       return
20523       end subroutine AFMforce
20524
20525 !-----------------------------------------------------------------------------
20526 #ifdef WHAM
20527       subroutine read_ssHist
20528 !      implicit none
20529 !      Includes
20530 !      include 'DIMENSIONS'
20531 !      include "DIMENSIONS.FREE"
20532 !      include 'COMMON.FREE'
20533 !     Local variables
20534       integer :: i,j
20535       character(len=80) :: controlcard
20536
20537       do i=1,dyn_nssHist
20538         call card_concat(controlcard,.true.)
20539         read(controlcard,*) &
20540              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20541       enddo
20542
20543       return
20544       end subroutine read_ssHist
20545 #endif
20546 !-----------------------------------------------------------------------------
20547       integer function indmat(i,j)
20548 !el
20549 ! get the position of the jth ijth fragment of the chain coordinate system
20550 ! in the fromto array.
20551         integer :: i,j
20552
20553         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20554       return
20555       end function indmat
20556 !-----------------------------------------------------------------------------
20557       real(kind=8) function sigm(x)
20558 !el
20559        real(kind=8) :: x
20560         sigm=0.25d0*x
20561       return
20562       end function sigm
20563 !-----------------------------------------------------------------------------
20564 !-----------------------------------------------------------------------------
20565       subroutine alloc_ener_arrays
20566 !EL Allocation of arrays used by module energy
20567       use MD_data, only: mset
20568 !el local variables
20569       integer :: i,j
20570
20571       if(nres.lt.100) then
20572         maxconts=10*nres
20573       elseif(nres.lt.200) then
20574         maxconts=10*nres      ! Max. number of contacts per residue
20575       else
20576         maxconts=10*nres ! (maxconts=maxres/4)
20577       endif
20578       maxcont=12*nres      ! Max. number of SC contacts
20579       maxvar=6*nres      ! Max. number of variables
20580 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20581       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20582 !----------------------
20583 ! arrays in subroutine init_int_table
20584 !el#ifdef MPI
20585 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20586 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20587 !el#endif
20588       allocate(nint_gr(nres))
20589       allocate(nscp_gr(nres))
20590       allocate(ielstart(nres))
20591       allocate(ielend(nres))
20592 !(maxres)
20593       allocate(istart(nres,maxint_gr))
20594       allocate(iend(nres,maxint_gr))
20595 !(maxres,maxint_gr)
20596       allocate(iscpstart(nres,maxint_gr))
20597       allocate(iscpend(nres,maxint_gr))
20598 !(maxres,maxint_gr)
20599       allocate(ielstart_vdw(nres))
20600       allocate(ielend_vdw(nres))
20601 !(maxres)
20602       allocate(nint_gr_nucl(nres))
20603       allocate(nscp_gr_nucl(nres))
20604       allocate(ielstart_nucl(nres))
20605       allocate(ielend_nucl(nres))
20606 !(maxres)
20607       allocate(istart_nucl(nres,maxint_gr))
20608       allocate(iend_nucl(nres,maxint_gr))
20609 !(maxres,maxint_gr)
20610       allocate(iscpstart_nucl(nres,maxint_gr))
20611       allocate(iscpend_nucl(nres,maxint_gr))
20612 !(maxres,maxint_gr)
20613       allocate(ielstart_vdw_nucl(nres))
20614       allocate(ielend_vdw_nucl(nres))
20615
20616       allocate(lentyp(0:nfgtasks-1))
20617 !(0:maxprocs-1)
20618 !----------------------
20619 ! commom.contacts
20620 !      common /contacts/
20621       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20622       allocate(icont(2,maxcont))
20623 !(2,maxcont)
20624 !      common /contacts1/
20625       allocate(num_cont(0:nres+4))
20626 !(maxres)
20627       allocate(jcont(maxconts,nres))
20628 !(maxconts,maxres)
20629       allocate(facont(maxconts,nres))
20630 !(maxconts,maxres)
20631       allocate(gacont(3,maxconts,nres))
20632 !(3,maxconts,maxres)
20633 !      common /contacts_hb/
20634       allocate(gacontp_hb1(3,maxconts,nres))
20635       allocate(gacontp_hb2(3,maxconts,nres))
20636       allocate(gacontp_hb3(3,maxconts,nres))
20637       allocate(gacontm_hb1(3,maxconts,nres))
20638       allocate(gacontm_hb2(3,maxconts,nres))
20639       allocate(gacontm_hb3(3,maxconts,nres))
20640       allocate(gacont_hbr(3,maxconts,nres))
20641       allocate(grij_hb_cont(3,maxconts,nres))
20642 !(3,maxconts,maxres)
20643       allocate(facont_hb(maxconts,nres))
20644
20645       allocate(ees0p(maxconts,nres))
20646       allocate(ees0m(maxconts,nres))
20647       allocate(d_cont(maxconts,nres))
20648       allocate(ees0plist(maxconts,nres))
20649
20650 !(maxconts,maxres)
20651       allocate(num_cont_hb(nres))
20652 !(maxres)
20653       allocate(jcont_hb(maxconts,nres))
20654 !(maxconts,maxres)
20655 !      common /rotat/
20656       allocate(Ug(2,2,nres))
20657       allocate(Ugder(2,2,nres))
20658       allocate(Ug2(2,2,nres))
20659       allocate(Ug2der(2,2,nres))
20660 !(2,2,maxres)
20661       allocate(obrot(2,nres))
20662       allocate(obrot2(2,nres))
20663       allocate(obrot_der(2,nres))
20664       allocate(obrot2_der(2,nres))
20665 !(2,maxres)
20666 !      common /precomp1/
20667       allocate(mu(2,nres))
20668       allocate(muder(2,nres))
20669       allocate(Ub2(2,nres))
20670       Ub2(1,:)=0.0d0
20671       Ub2(2,:)=0.0d0
20672       allocate(Ub2der(2,nres))
20673       allocate(Ctobr(2,nres))
20674       allocate(Ctobrder(2,nres))
20675       allocate(Dtobr2(2,nres))
20676       allocate(Dtobr2der(2,nres))
20677 !(2,maxres)
20678       allocate(EUg(2,2,nres))
20679       allocate(EUgder(2,2,nres))
20680       allocate(CUg(2,2,nres))
20681       allocate(CUgder(2,2,nres))
20682       allocate(DUg(2,2,nres))
20683       allocate(Dugder(2,2,nres))
20684       allocate(DtUg2(2,2,nres))
20685       allocate(DtUg2der(2,2,nres))
20686 !(2,2,maxres)
20687 !      common /precomp2/
20688       allocate(Ug2Db1t(2,nres))
20689       allocate(Ug2Db1tder(2,nres))
20690       allocate(CUgb2(2,nres))
20691       allocate(CUgb2der(2,nres))
20692 !(2,maxres)
20693       allocate(EUgC(2,2,nres))
20694       allocate(EUgCder(2,2,nres))
20695       allocate(EUgD(2,2,nres))
20696       allocate(EUgDder(2,2,nres))
20697       allocate(DtUg2EUg(2,2,nres))
20698       allocate(Ug2DtEUg(2,2,nres))
20699 !(2,2,maxres)
20700       allocate(Ug2DtEUgder(2,2,2,nres))
20701       allocate(DtUg2EUgder(2,2,2,nres))
20702 !(2,2,2,maxres)
20703       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20704       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20705       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20706       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20707
20708       allocate(ctilde(2,2,nres))
20709       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20710       allocate(gtb1(2,nres))
20711       allocate(gtb2(2,nres))
20712       allocate(cc(2,2,nres))
20713       allocate(dd(2,2,nres))
20714       allocate(ee(2,2,nres))
20715       allocate(gtcc(2,2,nres))
20716       allocate(gtdd(2,2,nres))
20717       allocate(gtee(2,2,nres))
20718       allocate(gUb2(2,nres))
20719       allocate(gteUg(2,2,nres))
20720
20721 !      common /rotat_old/
20722       allocate(costab(nres))
20723       allocate(sintab(nres))
20724       allocate(costab2(nres))
20725       allocate(sintab2(nres))
20726 !(maxres)
20727 !      common /dipmat/
20728       allocate(a_chuj(2,2,maxconts,nres))
20729 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20730       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20731 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20732 !      common /contdistrib/
20733       allocate(ncont_sent(nres))
20734       allocate(ncont_recv(nres))
20735
20736       allocate(iat_sent(nres))
20737 !(maxres)
20738       allocate(iint_sent(4,nres,nres))
20739       allocate(iint_sent_local(4,nres,nres))
20740 !(4,maxres,maxres)
20741       allocate(iturn3_sent(4,0:nres+4))
20742       allocate(iturn4_sent(4,0:nres+4))
20743       allocate(iturn3_sent_local(4,nres))
20744       allocate(iturn4_sent_local(4,nres))
20745 !(4,maxres)
20746       allocate(itask_cont_from(0:nfgtasks-1))
20747       allocate(itask_cont_to(0:nfgtasks-1))
20748 !(0:max_fg_procs-1)
20749
20750
20751
20752 !----------------------
20753 ! commom.deriv;
20754 !      common /derivat/
20755       allocate(dcdv(6,maxdim))
20756       allocate(dxdv(6,maxdim))
20757 !(6,maxdim)
20758       allocate(dxds(6,nres))
20759 !(6,maxres)
20760       allocate(gradx(3,-1:nres,0:2))
20761       allocate(gradc(3,-1:nres,0:2))
20762 !(3,maxres,2)
20763       allocate(gvdwx(3,-1:nres))
20764       allocate(gvdwc(3,-1:nres))
20765       allocate(gelc(3,-1:nres))
20766       allocate(gelc_long(3,-1:nres))
20767       allocate(gvdwpp(3,-1:nres))
20768       allocate(gvdwc_scpp(3,-1:nres))
20769       allocate(gradx_scp(3,-1:nres))
20770       allocate(gvdwc_scp(3,-1:nres))
20771       allocate(ghpbx(3,-1:nres))
20772       allocate(ghpbc(3,-1:nres))
20773       allocate(gradcorr(3,-1:nres))
20774       allocate(gradcorr_long(3,-1:nres))
20775       allocate(gradcorr5_long(3,-1:nres))
20776       allocate(gradcorr6_long(3,-1:nres))
20777       allocate(gcorr6_turn_long(3,-1:nres))
20778       allocate(gradxorr(3,-1:nres))
20779       allocate(gradcorr5(3,-1:nres))
20780       allocate(gradcorr6(3,-1:nres))
20781       allocate(gliptran(3,-1:nres))
20782       allocate(gliptranc(3,-1:nres))
20783       allocate(gliptranx(3,-1:nres))
20784       allocate(gshieldx(3,-1:nres))
20785       allocate(gshieldc(3,-1:nres))
20786       allocate(gshieldc_loc(3,-1:nres))
20787       allocate(gshieldx_ec(3,-1:nres))
20788       allocate(gshieldc_ec(3,-1:nres))
20789       allocate(gshieldc_loc_ec(3,-1:nres))
20790       allocate(gshieldx_t3(3,-1:nres))
20791       allocate(gshieldc_t3(3,-1:nres))
20792       allocate(gshieldc_loc_t3(3,-1:nres))
20793       allocate(gshieldx_t4(3,-1:nres))
20794       allocate(gshieldc_t4(3,-1:nres))
20795       allocate(gshieldc_loc_t4(3,-1:nres))
20796       allocate(gshieldx_ll(3,-1:nres))
20797       allocate(gshieldc_ll(3,-1:nres))
20798       allocate(gshieldc_loc_ll(3,-1:nres))
20799       allocate(grad_shield(3,-1:nres))
20800       allocate(gg_tube_sc(3,-1:nres))
20801       allocate(gg_tube(3,-1:nres))
20802       allocate(gradafm(3,-1:nres))
20803       allocate(gradb_nucl(3,-1:nres))
20804       allocate(gradbx_nucl(3,-1:nres))
20805       allocate(gvdwpsb1(3,-1:nres))
20806       allocate(gelpp(3,-1:nres))
20807       allocate(gvdwpsb(3,-1:nres))
20808       allocate(gelsbc(3,-1:nres))
20809       allocate(gelsbx(3,-1:nres))
20810       allocate(gvdwsbx(3,-1:nres))
20811       allocate(gvdwsbc(3,-1:nres))
20812       allocate(gsbloc(3,-1:nres))
20813       allocate(gsblocx(3,-1:nres))
20814       allocate(gradcorr_nucl(3,-1:nres))
20815       allocate(gradxorr_nucl(3,-1:nres))
20816       allocate(gradcorr3_nucl(3,-1:nres))
20817       allocate(gradxorr3_nucl(3,-1:nres))
20818       allocate(gvdwpp_nucl(3,-1:nres))
20819       allocate(gradpepcat(3,-1:nres))
20820       allocate(gradpepcatx(3,-1:nres))
20821       allocate(gradcatcat(3,-1:nres))
20822 !(3,maxres)
20823       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20824       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20825 ! grad for shielding surroing
20826       allocate(gloc(0:maxvar,0:2))
20827       allocate(gloc_x(0:maxvar,2))
20828 !(maxvar,2)
20829       allocate(gel_loc(3,-1:nres))
20830       allocate(gel_loc_long(3,-1:nres))
20831       allocate(gcorr3_turn(3,-1:nres))
20832       allocate(gcorr4_turn(3,-1:nres))
20833       allocate(gcorr6_turn(3,-1:nres))
20834       allocate(gradb(3,-1:nres))
20835       allocate(gradbx(3,-1:nres))
20836 !(3,maxres)
20837       allocate(gel_loc_loc(maxvar))
20838       allocate(gel_loc_turn3(maxvar))
20839       allocate(gel_loc_turn4(maxvar))
20840       allocate(gel_loc_turn6(maxvar))
20841       allocate(gcorr_loc(maxvar))
20842       allocate(g_corr5_loc(maxvar))
20843       allocate(g_corr6_loc(maxvar))
20844 !(maxvar)
20845       allocate(gsccorc(3,-1:nres))
20846       allocate(gsccorx(3,-1:nres))
20847 !(3,maxres)
20848       allocate(gsccor_loc(-1:nres))
20849 !(maxres)
20850       allocate(gvdwx_scbase(3,-1:nres))
20851       allocate(gvdwc_scbase(3,-1:nres))
20852       allocate(gvdwx_pepbase(3,-1:nres))
20853       allocate(gvdwc_pepbase(3,-1:nres))
20854       allocate(gvdwx_scpho(3,-1:nres))
20855       allocate(gvdwc_scpho(3,-1:nres))
20856       allocate(gvdwc_peppho(3,-1:nres))
20857
20858       allocate(dtheta(3,2,-1:nres))
20859 !(3,2,maxres)
20860       allocate(gscloc(3,-1:nres))
20861       allocate(gsclocx(3,-1:nres))
20862 !(3,maxres)
20863       allocate(dphi(3,3,-1:nres))
20864       allocate(dalpha(3,3,-1:nres))
20865       allocate(domega(3,3,-1:nres))
20866 !(3,3,maxres)
20867 !      common /deriv_scloc/
20868       allocate(dXX_C1tab(3,nres))
20869       allocate(dYY_C1tab(3,nres))
20870       allocate(dZZ_C1tab(3,nres))
20871       allocate(dXX_Ctab(3,nres))
20872       allocate(dYY_Ctab(3,nres))
20873       allocate(dZZ_Ctab(3,nres))
20874       allocate(dXX_XYZtab(3,nres))
20875       allocate(dYY_XYZtab(3,nres))
20876       allocate(dZZ_XYZtab(3,nres))
20877 !(3,maxres)
20878 !      common /mpgrad/
20879       allocate(jgrad_start(nres))
20880       allocate(jgrad_end(nres))
20881 !(maxres)
20882 !----------------------
20883
20884 !      common /indices/
20885       allocate(ibond_displ(0:nfgtasks-1))
20886       allocate(ibond_count(0:nfgtasks-1))
20887       allocate(ithet_displ(0:nfgtasks-1))
20888       allocate(ithet_count(0:nfgtasks-1))
20889       allocate(iphi_displ(0:nfgtasks-1))
20890       allocate(iphi_count(0:nfgtasks-1))
20891       allocate(iphi1_displ(0:nfgtasks-1))
20892       allocate(iphi1_count(0:nfgtasks-1))
20893       allocate(ivec_displ(0:nfgtasks-1))
20894       allocate(ivec_count(0:nfgtasks-1))
20895       allocate(iset_displ(0:nfgtasks-1))
20896       allocate(iset_count(0:nfgtasks-1))
20897       allocate(iint_count(0:nfgtasks-1))
20898       allocate(iint_displ(0:nfgtasks-1))
20899 !(0:max_fg_procs-1)
20900 !----------------------
20901 ! common.MD
20902 !      common /mdgrad/
20903       allocate(gcart(3,-1:nres))
20904       allocate(gxcart(3,-1:nres))
20905 !(3,0:MAXRES)
20906       allocate(gradcag(3,-1:nres))
20907       allocate(gradxag(3,-1:nres))
20908 !(3,MAXRES)
20909 !      common /back_constr/
20910 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20911       allocate(dutheta(nres))
20912       allocate(dugamma(nres))
20913 !(maxres)
20914       allocate(duscdiff(3,nres))
20915       allocate(duscdiffx(3,nres))
20916 !(3,maxres)
20917 !el i io:read_fragments
20918 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20919 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20920 !      common /qmeas/
20921 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20922 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20923       allocate(mset(0:nprocs))  !(maxprocs/20)
20924       mset(:)=0
20925 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20926 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20927       allocate(dUdconst(3,0:nres))
20928       allocate(dUdxconst(3,0:nres))
20929       allocate(dqwol(3,0:nres))
20930       allocate(dxqwol(3,0:nres))
20931 !(3,0:MAXRES)
20932 !----------------------
20933 ! common.sbridge
20934 !      common /sbridge/ in io_common: read_bridge
20935 !el    allocate((:),allocatable :: iss      !(maxss)
20936 !      common /links/  in io_common: read_bridge
20937 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20938 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20939 !      common /dyn_ssbond/
20940 ! and side-chain vectors in theta or phi.
20941       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20942 !(maxres,maxres)
20943 !      do i=1,nres
20944 !        do j=i+1,nres
20945       dyn_ssbond_ij(:,:)=1.0d300
20946 !        enddo
20947 !      enddo
20948
20949 !      if (nss.gt.0) then
20950         allocate(idssb(maxdim),jdssb(maxdim))
20951 !        allocate(newihpb(nss),newjhpb(nss))
20952 !(maxdim)
20953 !      endif
20954       allocate(ishield_list(-1:nres))
20955       allocate(shield_list(maxcontsshi,-1:nres))
20956       allocate(dyn_ss_mask(nres))
20957       allocate(fac_shield(-1:nres))
20958       allocate(enetube(nres*2))
20959       allocate(enecavtube(nres*2))
20960
20961 !(maxres)
20962       dyn_ss_mask(:)=.false.
20963 !----------------------
20964 ! common.sccor
20965 ! Parameters of the SCCOR term
20966 !      common/sccor/
20967 !el in io_conf: parmread
20968 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20969 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20970 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20971 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20972 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20973 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20974 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20975 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20976 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20977 !----------------
20978       allocate(gloc_sc(3,0:2*nres,0:10))
20979 !(3,0:maxres2,10)maxres2=2*maxres
20980       allocate(dcostau(3,3,3,2*nres))
20981       allocate(dsintau(3,3,3,2*nres))
20982       allocate(dtauangle(3,3,3,2*nres))
20983       allocate(dcosomicron(3,3,3,2*nres))
20984       allocate(domicron(3,3,3,2*nres))
20985 !(3,3,3,maxres2)maxres2=2*maxres
20986 !----------------------
20987 ! common.var
20988 !      common /restr/
20989       allocate(varall(maxvar))
20990 !(maxvar)(maxvar=6*maxres)
20991       allocate(mask_theta(nres))
20992       allocate(mask_phi(nres))
20993       allocate(mask_side(nres))
20994 !(maxres)
20995 !----------------------
20996 ! common.vectors
20997 !      common /vectors/
20998       allocate(uy(3,nres))
20999       allocate(uz(3,nres))
21000 !(3,maxres)
21001       allocate(uygrad(3,3,2,nres))
21002       allocate(uzgrad(3,3,2,nres))
21003 !(3,3,2,maxres)
21004 ! allocateion of lists JPRDLA
21005       allocate(newcontlistppi(200*nres))
21006       allocate(newcontlistscpi(200*nres))
21007       allocate(newcontlisti(200*nres))
21008       allocate(newcontlistppj(200*nres))
21009       allocate(newcontlistscpj(200*nres))
21010       allocate(newcontlistj(200*nres))
21011
21012       return
21013       end subroutine alloc_ener_arrays
21014 !-----------------------------------------------------------------
21015       subroutine ebond_nucl(estr_nucl)
21016 !c
21017 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
21018 !c
21019
21020       real(kind=8),dimension(3) :: u,ud
21021       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
21022       real(kind=8) :: estr_nucl,diff
21023       integer :: iti,i,j,k,nbi
21024       estr_nucl=0.0d0
21025 !C      print *,"I enter ebond"
21026       if (energy_dec) &
21027       write (iout,*) "ibondp_start,ibondp_end",&
21028        ibondp_nucl_start,ibondp_nucl_end
21029       do i=ibondp_nucl_start,ibondp_nucl_end
21030         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
21031          itype(i,2).eq.ntyp1_molec(2)) cycle
21032 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
21033 !          do j=1,3
21034 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
21035 !     &      *dc(j,i-1)/vbld(i)
21036 !          enddo
21037 !          if (energy_dec) write(iout,*)
21038 !     &       "estr1",i,vbld(i),distchainmax,
21039 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
21040
21041           diff = vbld(i)-vbldp0_nucl
21042           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
21043           vbldp0_nucl,diff,AKP_nucl*diff*diff
21044           estr_nucl=estr_nucl+diff*diff
21045 !          print *,estr_nucl
21046           do j=1,3
21047             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
21048           enddo
21049 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
21050       enddo
21051       estr_nucl=0.5d0*AKP_nucl*estr_nucl
21052 !      print *,"partial sum", estr_nucl,AKP_nucl
21053
21054       if (energy_dec) &
21055       write (iout,*) "ibondp_start,ibondp_end",&
21056        ibond_nucl_start,ibond_nucl_end
21057
21058       do i=ibond_nucl_start,ibond_nucl_end
21059 !C        print *, "I am stuck",i
21060         iti=itype(i,2)
21061         if (iti.eq.ntyp1_molec(2)) cycle
21062           nbi=nbondterm_nucl(iti)
21063 !C        print *,iti,nbi
21064           if (nbi.eq.1) then
21065             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
21066
21067             if (energy_dec) &
21068            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
21069            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
21070             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
21071 !            print *,estr_nucl
21072             do j=1,3
21073               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
21074             enddo
21075           else
21076             do j=1,nbi
21077               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
21078               ud(j)=aksc_nucl(j,iti)*diff
21079               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21080             enddo
21081             uprod=u(1)
21082             do j=2,nbi
21083               uprod=uprod*u(j)
21084             enddo
21085             usum=0.0d0
21086             usumsqder=0.0d0
21087             do j=1,nbi
21088               uprod1=1.0d0
21089               uprod2=1.0d0
21090               do k=1,nbi
21091                 if (k.ne.j) then
21092                   uprod1=uprod1*u(k)
21093                   uprod2=uprod2*u(k)*u(k)
21094                 endif
21095               enddo
21096               usum=usum+uprod1
21097               usumsqder=usumsqder+ud(j)*uprod2
21098             enddo
21099             estr_nucl=estr_nucl+uprod/usum
21100             do j=1,3
21101              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21102             enddo
21103         endif
21104       enddo
21105 !C      print *,"I am about to leave ebond"
21106       return
21107       end subroutine ebond_nucl
21108
21109 !-----------------------------------------------------------------------------
21110       subroutine ebend_nucl(etheta_nucl)
21111       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21112       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21113       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21114       logical :: lprn=.false., lprn1=.false.
21115 !el local variables
21116       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21117       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21118       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21119 ! local variables for constrains
21120       real(kind=8) :: difi,thetiii
21121        integer itheta
21122       etheta_nucl=0.0D0
21123 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21124       do i=ithet_nucl_start,ithet_nucl_end
21125         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21126         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21127         (itype(i,2).eq.ntyp1_molec(2))) cycle
21128         dethetai=0.0d0
21129         dephii=0.0d0
21130         dephii1=0.0d0
21131         theti2=0.5d0*theta(i)
21132         ityp2=ithetyp_nucl(itype(i-1,2))
21133         do k=1,nntheterm_nucl
21134           coskt(k)=dcos(k*theti2)
21135           sinkt(k)=dsin(k*theti2)
21136         enddo
21137         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21138 #ifdef OSF
21139           phii=phi(i)
21140           if (phii.ne.phii) phii=150.0
21141 #else
21142           phii=phi(i)
21143 #endif
21144           ityp1=ithetyp_nucl(itype(i-2,2))
21145           do k=1,nsingle_nucl
21146             cosph1(k)=dcos(k*phii)
21147             sinph1(k)=dsin(k*phii)
21148           enddo
21149         else
21150           phii=0.0d0
21151           ityp1=nthetyp_nucl+1
21152           do k=1,nsingle_nucl
21153             cosph1(k)=0.0d0
21154             sinph1(k)=0.0d0
21155           enddo
21156         endif
21157
21158         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21159 #ifdef OSF
21160           phii1=phi(i+1)
21161           if (phii1.ne.phii1) phii1=150.0
21162           phii1=pinorm(phii1)
21163 #else
21164           phii1=phi(i+1)
21165 #endif
21166           ityp3=ithetyp_nucl(itype(i,2))
21167           do k=1,nsingle_nucl
21168             cosph2(k)=dcos(k*phii1)
21169             sinph2(k)=dsin(k*phii1)
21170           enddo
21171         else
21172           phii1=0.0d0
21173           ityp3=nthetyp_nucl+1
21174           do k=1,nsingle_nucl
21175             cosph2(k)=0.0d0
21176             sinph2(k)=0.0d0
21177           enddo
21178         endif
21179         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21180         do k=1,ndouble_nucl
21181           do l=1,k-1
21182             ccl=cosph1(l)*cosph2(k-l)
21183             ssl=sinph1(l)*sinph2(k-l)
21184             scl=sinph1(l)*cosph2(k-l)
21185             csl=cosph1(l)*sinph2(k-l)
21186             cosph1ph2(l,k)=ccl-ssl
21187             cosph1ph2(k,l)=ccl+ssl
21188             sinph1ph2(l,k)=scl+csl
21189             sinph1ph2(k,l)=scl-csl
21190           enddo
21191         enddo
21192         if (lprn) then
21193         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21194          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21195         write (iout,*) "coskt and sinkt",nntheterm_nucl
21196         do k=1,nntheterm_nucl
21197           write (iout,*) k,coskt(k),sinkt(k)
21198         enddo
21199         endif
21200         do k=1,ntheterm_nucl
21201           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21202           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21203            *coskt(k)
21204           if (lprn)&
21205          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21206           " ethetai",ethetai
21207         enddo
21208         if (lprn) then
21209         write (iout,*) "cosph and sinph"
21210         do k=1,nsingle_nucl
21211           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21212         enddo
21213         write (iout,*) "cosph1ph2 and sinph2ph2"
21214         do k=2,ndouble_nucl
21215           do l=1,k-1
21216             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21217               sinph1ph2(l,k),sinph1ph2(k,l)
21218           enddo
21219         enddo
21220         write(iout,*) "ethetai",ethetai
21221         endif
21222         do m=1,ntheterm2_nucl
21223           do k=1,nsingle_nucl
21224             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21225               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21226               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21227               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21228             ethetai=ethetai+sinkt(m)*aux
21229             dethetai=dethetai+0.5d0*m*aux*coskt(m)
21230             dephii=dephii+k*sinkt(m)*(&
21231                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21232                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21233             dephii1=dephii1+k*sinkt(m)*(&
21234                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21235                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21236             if (lprn) &
21237            write (iout,*) "m",m," k",k," bbthet",&
21238               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21239               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21240               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21241               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21242           enddo
21243         enddo
21244         if (lprn) &
21245         write(iout,*) "ethetai",ethetai
21246         do m=1,ntheterm3_nucl
21247           do k=2,ndouble_nucl
21248             do l=1,k-1
21249               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21250                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21251                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21252                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21253               ethetai=ethetai+sinkt(m)*aux
21254               dethetai=dethetai+0.5d0*m*coskt(m)*aux
21255               dephii=dephii+l*sinkt(m)*(&
21256                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21257                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21258                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21259                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21260               dephii1=dephii1+(k-l)*sinkt(m)*( &
21261                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21262                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21263                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21264                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21265               if (lprn) then
21266               write (iout,*) "m",m," k",k," l",l," ffthet", &
21267                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21268                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21269                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21270                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21271               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21272                  cosph1ph2(k,l)*sinkt(m),&
21273                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21274               endif
21275             enddo
21276           enddo
21277         enddo
21278 10      continue
21279         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21280         i,theta(i)*rad2deg,phii*rad2deg, &
21281         phii1*rad2deg,ethetai
21282         etheta_nucl=etheta_nucl+ethetai
21283 !        print *,i,"partial sum",etheta_nucl
21284         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21285         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21286         gloc(nphi+i-2,icg)=wang_nucl*dethetai
21287       enddo
21288       return
21289       end subroutine ebend_nucl
21290 !----------------------------------------------------
21291       subroutine etor_nucl(etors_nucl)
21292 !      implicit real*8 (a-h,o-z)
21293 !      include 'DIMENSIONS'
21294 !      include 'COMMON.VAR'
21295 !      include 'COMMON.GEO'
21296 !      include 'COMMON.LOCAL'
21297 !      include 'COMMON.TORSION'
21298 !      include 'COMMON.INTERACT'
21299 !      include 'COMMON.DERIV'
21300 !      include 'COMMON.CHAIN'
21301 !      include 'COMMON.NAMES'
21302 !      include 'COMMON.IOUNITS'
21303 !      include 'COMMON.FFIELD'
21304 !      include 'COMMON.TORCNSTR'
21305 !      include 'COMMON.CONTROL'
21306       real(kind=8) :: etors_nucl,edihcnstr
21307       logical :: lprn
21308 !el local variables
21309       integer :: i,j,iblock,itori,itori1
21310       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21311                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21312 ! Set lprn=.true. for debugging
21313       lprn=.false.
21314 !     lprn=.true.
21315       etors_nucl=0.0D0
21316 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21317       do i=iphi_nucl_start,iphi_nucl_end
21318         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21319              .or. itype(i-3,2).eq.ntyp1_molec(2) &
21320              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21321         etors_ii=0.0D0
21322         itori=itortyp_nucl(itype(i-2,2))
21323         itori1=itortyp_nucl(itype(i-1,2))
21324         phii=phi(i)
21325 !         print *,i,itori,itori1
21326         gloci=0.0D0
21327 !C Regular cosine and sine terms
21328         do j=1,nterm_nucl(itori,itori1)
21329           v1ij=v1_nucl(j,itori,itori1)
21330           v2ij=v2_nucl(j,itori,itori1)
21331           cosphi=dcos(j*phii)
21332           sinphi=dsin(j*phii)
21333           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21334           if (energy_dec) etors_ii=etors_ii+&
21335                      v1ij*cosphi+v2ij*sinphi
21336           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21337         enddo
21338 !C Lorentz terms
21339 !C                         v1
21340 !C  E = SUM ----------------------------------- - v1
21341 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21342 !C
21343         cosphi=dcos(0.5d0*phii)
21344         sinphi=dsin(0.5d0*phii)
21345         do j=1,nlor_nucl(itori,itori1)
21346           vl1ij=vlor1_nucl(j,itori,itori1)
21347           vl2ij=vlor2_nucl(j,itori,itori1)
21348           vl3ij=vlor3_nucl(j,itori,itori1)
21349           pom=vl2ij*cosphi+vl3ij*sinphi
21350           pom1=1.0d0/(pom*pom+1.0d0)
21351           etors_nucl=etors_nucl+vl1ij*pom1
21352           if (energy_dec) etors_ii=etors_ii+ &
21353                      vl1ij*pom1
21354           pom=-pom*pom1*pom1
21355           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21356         enddo
21357 !C Subtract the constant term
21358         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21359           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21360               'etor',i,etors_ii-v0_nucl(itori,itori1)
21361         if (lprn) &
21362        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21363        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21364        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21365         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21366 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21367       enddo
21368       return
21369       end subroutine etor_nucl
21370 !------------------------------------------------------------
21371       subroutine epp_nucl_sub(evdw1,ees)
21372 !C
21373 !C This subroutine calculates the average interaction energy and its gradient
21374 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21375 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21376 !C The potential depends both on the distance of peptide-group centers and on
21377 !C the orientation of the CA-CA virtual bonds.
21378 !C
21379       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21380       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
21381       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21382                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21383                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21384       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21385                     dist_temp, dist_init,sss_grad,fac,evdw1ij
21386       integer xshift,yshift,zshift
21387       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21388       real(kind=8) :: ees,eesij
21389 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21390       real(kind=8) scal_el /0.5d0/
21391       t_eelecij=0.0d0
21392       ees=0.0D0
21393       evdw1=0.0D0
21394       ind=0
21395 !c
21396 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21397 !c
21398 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21399       do i=iatel_s_nucl,iatel_e_nucl
21400         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21401         dxi=dc(1,i)
21402         dyi=dc(2,i)
21403         dzi=dc(3,i)
21404         dx_normi=dc_norm(1,i)
21405         dy_normi=dc_norm(2,i)
21406         dz_normi=dc_norm(3,i)
21407         xmedi=c(1,i)+0.5d0*dxi
21408         ymedi=c(2,i)+0.5d0*dyi
21409         zmedi=c(3,i)+0.5d0*dzi
21410           xmedi=dmod(xmedi,boxxsize)
21411           if (xmedi.lt.0) xmedi=xmedi+boxxsize
21412           ymedi=dmod(ymedi,boxysize)
21413           if (ymedi.lt.0) ymedi=ymedi+boxysize
21414           zmedi=dmod(zmedi,boxzsize)
21415           if (zmedi.lt.0) zmedi=zmedi+boxzsize
21416
21417         do j=ielstart_nucl(i),ielend_nucl(i)
21418           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21419           ind=ind+1
21420           dxj=dc(1,j)
21421           dyj=dc(2,j)
21422           dzj=dc(3,j)
21423 !          xj=c(1,j)+0.5D0*dxj-xmedi
21424 !          yj=c(2,j)+0.5D0*dyj-ymedi
21425 !          zj=c(3,j)+0.5D0*dzj-zmedi
21426           xj=c(1,j)+0.5D0*dxj
21427           yj=c(2,j)+0.5D0*dyj
21428           zj=c(3,j)+0.5D0*dzj
21429           xj=mod(xj,boxxsize)
21430           if (xj.lt.0) xj=xj+boxxsize
21431           yj=mod(yj,boxysize)
21432           if (yj.lt.0) yj=yj+boxysize
21433           zj=mod(zj,boxzsize)
21434           if (zj.lt.0) zj=zj+boxzsize
21435       isubchap=0
21436       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21437       xj_safe=xj
21438       yj_safe=yj
21439       zj_safe=zj
21440       do xshift=-1,1
21441       do yshift=-1,1
21442       do zshift=-1,1
21443           xj=xj_safe+xshift*boxxsize
21444           yj=yj_safe+yshift*boxysize
21445           zj=zj_safe+zshift*boxzsize
21446           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
21447           if(dist_temp.lt.dist_init) then
21448             dist_init=dist_temp
21449             xj_temp=xj
21450             yj_temp=yj
21451             zj_temp=zj
21452             isubchap=1
21453           endif
21454        enddo
21455        enddo
21456        enddo
21457        if (isubchap.eq.1) then
21458 !C          print *,i,j
21459           xj=xj_temp-xmedi
21460           yj=yj_temp-ymedi
21461           zj=zj_temp-zmedi
21462        else
21463           xj=xj_safe-xmedi
21464           yj=yj_safe-ymedi
21465           zj=zj_safe-zmedi
21466        endif
21467
21468           rij=xj*xj+yj*yj+zj*zj
21469 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21470           fac=(r0pp**2/rij)**3
21471           ev1=epspp*fac*fac
21472           ev2=epspp*fac
21473           evdw1ij=ev1-2*ev2
21474           fac=(-ev1-evdw1ij)/rij
21475 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21476           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21477           evdw1=evdw1+evdw1ij
21478 !C
21479 !C Calculate contributions to the Cartesian gradient.
21480 !C
21481           ggg(1)=fac*xj
21482           ggg(2)=fac*yj
21483           ggg(3)=fac*zj
21484           do k=1,3
21485             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21486             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21487           enddo
21488 !c phoshate-phosphate electrostatic interactions
21489           rij=dsqrt(rij)
21490           fac=1.0d0/rij
21491           eesij=dexp(-BEES*rij)*fac
21492 !          write (2,*)"fac",fac," eesijpp",eesij
21493           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21494           ees=ees+eesij
21495 !c          fac=-eesij*fac
21496           fac=-(fac+BEES)*eesij*fac
21497           ggg(1)=fac*xj
21498           ggg(2)=fac*yj
21499           ggg(3)=fac*zj
21500 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21501 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21502 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21503           do k=1,3
21504             gelpp(k,i)=gelpp(k,i)-ggg(k)
21505             gelpp(k,j)=gelpp(k,j)+ggg(k)
21506           enddo
21507         enddo ! j
21508       enddo   ! i
21509 !c      ees=332.0d0*ees
21510       ees=AEES*ees
21511       do i=nnt,nct
21512 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21513         do k=1,3
21514           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21515 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21516           gelpp(k,i)=AEES*gelpp(k,i)
21517         enddo
21518 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21519       enddo
21520 !c      write (2,*) "total EES",ees
21521       return
21522       end subroutine epp_nucl_sub
21523 !---------------------------------------------------------------------
21524       subroutine epsb(evdwpsb,eelpsb)
21525 !      use comm_locel
21526 !C
21527 !C This subroutine calculates the excluded-volume interaction energy between
21528 !C peptide-group centers and side chains and its gradient in virtual-bond and
21529 !C side-chain vectors.
21530 !C
21531       real(kind=8),dimension(3):: ggg
21532       integer :: i,iint,j,k,iteli,itypj,subchap
21533       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21534                    e1,e2,evdwij,rij,evdwpsb,eelpsb
21535       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21536                     dist_temp, dist_init
21537       integer xshift,yshift,zshift
21538
21539 !cd    print '(a)','Enter ESCP'
21540 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21541       eelpsb=0.0d0
21542       evdwpsb=0.0d0
21543 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21544       do i=iatscp_s_nucl,iatscp_e_nucl
21545         if (itype(i,2).eq.ntyp1_molec(2) &
21546          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21547         xi=0.5D0*(c(1,i)+c(1,i+1))
21548         yi=0.5D0*(c(2,i)+c(2,i+1))
21549         zi=0.5D0*(c(3,i)+c(3,i+1))
21550           xi=mod(xi,boxxsize)
21551           if (xi.lt.0) xi=xi+boxxsize
21552           yi=mod(yi,boxysize)
21553           if (yi.lt.0) yi=yi+boxysize
21554           zi=mod(zi,boxzsize)
21555           if (zi.lt.0) zi=zi+boxzsize
21556
21557         do iint=1,nscp_gr_nucl(i)
21558
21559         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21560           itypj=itype(j,2)
21561           if (itypj.eq.ntyp1_molec(2)) cycle
21562 !C Uncomment following three lines for SC-p interactions
21563 !c         xj=c(1,nres+j)-xi
21564 !c         yj=c(2,nres+j)-yi
21565 !c         zj=c(3,nres+j)-zi
21566 !C Uncomment following three lines for Ca-p interactions
21567 !          xj=c(1,j)-xi
21568 !          yj=c(2,j)-yi
21569 !          zj=c(3,j)-zi
21570           xj=c(1,j)
21571           yj=c(2,j)
21572           zj=c(3,j)
21573           xj=mod(xj,boxxsize)
21574           if (xj.lt.0) xj=xj+boxxsize
21575           yj=mod(yj,boxysize)
21576           if (yj.lt.0) yj=yj+boxysize
21577           zj=mod(zj,boxzsize)
21578           if (zj.lt.0) zj=zj+boxzsize
21579       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21580       xj_safe=xj
21581       yj_safe=yj
21582       zj_safe=zj
21583       subchap=0
21584       do xshift=-1,1
21585       do yshift=-1,1
21586       do zshift=-1,1
21587           xj=xj_safe+xshift*boxxsize
21588           yj=yj_safe+yshift*boxysize
21589           zj=zj_safe+zshift*boxzsize
21590           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21591           if(dist_temp.lt.dist_init) then
21592             dist_init=dist_temp
21593             xj_temp=xj
21594             yj_temp=yj
21595             zj_temp=zj
21596             subchap=1
21597           endif
21598        enddo
21599        enddo
21600        enddo
21601        if (subchap.eq.1) then
21602           xj=xj_temp-xi
21603           yj=yj_temp-yi
21604           zj=zj_temp-zi
21605        else
21606           xj=xj_safe-xi
21607           yj=yj_safe-yi
21608           zj=zj_safe-zi
21609        endif
21610
21611           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21612           fac=rrij**expon2
21613           e1=fac*fac*aad_nucl(itypj)
21614           e2=fac*bad_nucl(itypj)
21615           if (iabs(j-i) .le. 2) then
21616             e1=scal14*e1
21617             e2=scal14*e2
21618           endif
21619           evdwij=e1+e2
21620           evdwpsb=evdwpsb+evdwij
21621           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21622              'evdw2',i,j,evdwij,"tu4"
21623 !C
21624 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21625 !C
21626           fac=-(evdwij+e1)*rrij
21627           ggg(1)=xj*fac
21628           ggg(2)=yj*fac
21629           ggg(3)=zj*fac
21630           do k=1,3
21631             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21632             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21633           enddo
21634         enddo
21635
21636         enddo ! iint
21637       enddo ! i
21638       do i=1,nct
21639         do j=1,3
21640           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21641           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21642         enddo
21643       enddo
21644       return
21645       end subroutine epsb
21646
21647 !------------------------------------------------------
21648       subroutine esb_gb(evdwsb,eelsb)
21649       use comm_locel
21650       use calc_data_nucl
21651       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21652       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21653       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21654       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21655                     dist_temp, dist_init,aa,bb,faclip,sig0ij
21656       integer :: ii
21657       logical lprn
21658       evdw=0.0D0
21659       eelsb=0.0d0
21660       ecorr=0.0d0
21661       evdwsb=0.0D0
21662       lprn=.false.
21663       ind=0
21664 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21665       do i=iatsc_s_nucl,iatsc_e_nucl
21666         num_conti=0
21667         num_conti2=0
21668         itypi=itype(i,2)
21669 !        PRINT *,"I=",i,itypi
21670         if (itypi.eq.ntyp1_molec(2)) cycle
21671         itypi1=itype(i+1,2)
21672         xi=c(1,nres+i)
21673         yi=c(2,nres+i)
21674         zi=c(3,nres+i)
21675           xi=dmod(xi,boxxsize)
21676           if (xi.lt.0) xi=xi+boxxsize
21677           yi=dmod(yi,boxysize)
21678           if (yi.lt.0) yi=yi+boxysize
21679           zi=dmod(zi,boxzsize)
21680           if (zi.lt.0) zi=zi+boxzsize
21681
21682         dxi=dc_norm(1,nres+i)
21683         dyi=dc_norm(2,nres+i)
21684         dzi=dc_norm(3,nres+i)
21685         dsci_inv=vbld_inv(i+nres)
21686 !C
21687 !C Calculate SC interaction energy.
21688 !C
21689         do iint=1,nint_gr_nucl(i)
21690 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21691           do j=istart_nucl(i,iint),iend_nucl(i,iint)
21692             ind=ind+1
21693 !            print *,"JESTEM"
21694             itypj=itype(j,2)
21695             if (itypj.eq.ntyp1_molec(2)) cycle
21696             dscj_inv=vbld_inv(j+nres)
21697             sig0ij=sigma_nucl(itypi,itypj)
21698             chi1=chi_nucl(itypi,itypj)
21699             chi2=chi_nucl(itypj,itypi)
21700             chi12=chi1*chi2
21701             chip1=chip_nucl(itypi,itypj)
21702             chip2=chip_nucl(itypj,itypi)
21703             chip12=chip1*chip2
21704 !            xj=c(1,nres+j)-xi
21705 !            yj=c(2,nres+j)-yi
21706 !            zj=c(3,nres+j)-zi
21707            xj=c(1,nres+j)
21708            yj=c(2,nres+j)
21709            zj=c(3,nres+j)
21710           xj=dmod(xj,boxxsize)
21711           if (xj.lt.0) xj=xj+boxxsize
21712           yj=dmod(yj,boxysize)
21713           if (yj.lt.0) yj=yj+boxysize
21714           zj=dmod(zj,boxzsize)
21715           if (zj.lt.0) zj=zj+boxzsize
21716       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21717       xj_safe=xj
21718       yj_safe=yj
21719       zj_safe=zj
21720       subchap=0
21721       do xshift=-1,1
21722       do yshift=-1,1
21723       do zshift=-1,1
21724           xj=xj_safe+xshift*boxxsize
21725           yj=yj_safe+yshift*boxysize
21726           zj=zj_safe+zshift*boxzsize
21727           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21728           if(dist_temp.lt.dist_init) then
21729             dist_init=dist_temp
21730             xj_temp=xj
21731             yj_temp=yj
21732             zj_temp=zj
21733             subchap=1
21734           endif
21735        enddo
21736        enddo
21737        enddo
21738        if (subchap.eq.1) then
21739           xj=xj_temp-xi
21740           yj=yj_temp-yi
21741           zj=zj_temp-zi
21742        else
21743           xj=xj_safe-xi
21744           yj=yj_safe-yi
21745           zj=zj_safe-zi
21746        endif
21747
21748             dxj=dc_norm(1,nres+j)
21749             dyj=dc_norm(2,nres+j)
21750             dzj=dc_norm(3,nres+j)
21751             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21752             rij=dsqrt(rrij)
21753 !C Calculate angle-dependent terms of energy and contributions to their
21754 !C derivatives.
21755             erij(1)=xj*rij
21756             erij(2)=yj*rij
21757             erij(3)=zj*rij
21758             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21759             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21760             om12=dxi*dxj+dyi*dyj+dzi*dzj
21761             call sc_angular_nucl
21762             sigsq=1.0D0/sigsq
21763             sig=sig0ij*dsqrt(sigsq)
21764             rij_shift=1.0D0/rij-sig+sig0ij
21765 !            print *,rij_shift,"rij_shift"
21766 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21767 !c     &       " rij_shift",rij_shift
21768             if (rij_shift.le.0.0D0) then
21769               evdw=1.0D20
21770               return
21771             endif
21772             sigder=-sig*sigsq
21773 !c---------------------------------------------------------------
21774             rij_shift=1.0D0/rij_shift
21775             fac=rij_shift**expon
21776             e1=fac*fac*aa_nucl(itypi,itypj)
21777             e2=fac*bb_nucl(itypi,itypj)
21778             evdwij=eps1*eps2rt*(e1+e2)
21779 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21780 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21781             eps2der=evdwij
21782             evdwij=evdwij*eps2rt
21783             evdwsb=evdwsb+evdwij
21784             if (lprn) then
21785             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21786             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21787             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21788              restyp(itypi,2),i,restyp(itypj,2),j, &
21789              epsi,sigm,chi1,chi2,chip1,chip2, &
21790              eps1,eps2rt**2,sig,sig0ij, &
21791              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21792             evdwij
21793             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21794             endif
21795
21796             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21797                              'evdw',i,j,evdwij,"tu3"
21798
21799
21800 !C Calculate gradient components.
21801             e1=e1*eps1*eps2rt**2
21802             fac=-expon*(e1+evdwij)*rij_shift
21803             sigder=fac*sigder
21804             fac=rij*fac
21805 !c            fac=0.0d0
21806 !C Calculate the radial part of the gradient
21807             gg(1)=xj*fac
21808             gg(2)=yj*fac
21809             gg(3)=zj*fac
21810 !C Calculate angular part of the gradient.
21811             call sc_grad_nucl
21812             call eelsbij(eelij,num_conti2)
21813             if (energy_dec .and. &
21814            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21815           write (istat,'(e14.5)') evdwij
21816             eelsb=eelsb+eelij
21817           enddo      ! j
21818         enddo        ! iint
21819         num_cont_hb(i)=num_conti2
21820       enddo          ! i
21821 !c      write (iout,*) "Number of loop steps in EGB:",ind
21822 !cccc      energy_dec=.false.
21823       return
21824       end subroutine esb_gb
21825 !-------------------------------------------------------------------------------
21826       subroutine eelsbij(eesij,num_conti2)
21827       use comm_locel
21828       use calc_data_nucl
21829       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21830       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21831       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21832                     dist_temp, dist_init,rlocshield,fracinbuf
21833       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21834
21835 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21836       real(kind=8) scal_el /0.5d0/
21837       integer :: iteli,itelj,kkk,kkll,m,isubchap
21838       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21839       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21840       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21841                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21842                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21843                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21844                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21845                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21846                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21847                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21848       ind=ind+1
21849       itypi=itype(i,2)
21850       itypj=itype(j,2)
21851 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21852       ael6i=ael6_nucl(itypi,itypj)
21853       ael3i=ael3_nucl(itypi,itypj)
21854       ael63i=ael63_nucl(itypi,itypj)
21855       ael32i=ael32_nucl(itypi,itypj)
21856 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21857 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21858       dxj=dc(1,j+nres)
21859       dyj=dc(2,j+nres)
21860       dzj=dc(3,j+nres)
21861       dx_normi=dc_norm(1,i+nres)
21862       dy_normi=dc_norm(2,i+nres)
21863       dz_normi=dc_norm(3,i+nres)
21864       dx_normj=dc_norm(1,j+nres)
21865       dy_normj=dc_norm(2,j+nres)
21866       dz_normj=dc_norm(3,j+nres)
21867 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21868 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21869 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21870       if (ipot_nucl.ne.2) then
21871         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21872         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21873         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21874       else
21875         cosa=om12
21876         cosb=om1
21877         cosg=om2
21878       endif
21879       r3ij=rij*rrij
21880       r6ij=r3ij*r3ij
21881       fac=cosa-3.0D0*cosb*cosg
21882       facfac=fac*fac
21883       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21884       fac3=ael6i*r6ij
21885       fac4=ael3i*r3ij
21886       fac5=ael63i*r6ij
21887       fac6=ael32i*r6ij
21888 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21889 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21890       el1=fac3*(4.0D0+facfac-fac1)
21891       el2=fac4*fac
21892       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21893       el4=fac6*facfac
21894       eesij=el1+el2+el3+el4
21895 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21896       ees0ij=4.0D0+facfac-fac1
21897
21898       if (energy_dec) then
21899           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21900           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21901            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21902            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21903            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21904           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21905       endif
21906
21907 !C
21908 !C Calculate contributions to the Cartesian gradient.
21909 !C
21910       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21911       fac1=fac
21912 !c      erij(1)=xj*rmij
21913 !c      erij(2)=yj*rmij
21914 !c      erij(3)=zj*rmij
21915 !*
21916 !* Radial derivatives. First process both termini of the fragment (i,j)
21917 !*
21918       ggg(1)=facel*xj
21919       ggg(2)=facel*yj
21920       ggg(3)=facel*zj
21921       do k=1,3
21922         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21923         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21924         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21925         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21926       enddo
21927 !*
21928 !* Angular part
21929 !*
21930       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21931       fac4=-3.0D0*fac4
21932       fac3=-6.0D0*fac3
21933       fac5= 6.0d0*fac5
21934       fac6=-6.0d0*fac6
21935       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21936        fac6*fac1*cosg
21937       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21938        fac6*fac1*cosb
21939       do k=1,3
21940         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21941         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21942       enddo
21943       do k=1,3
21944         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21945       enddo
21946       do k=1,3
21947         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21948              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21949              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21950         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21951              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21952              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21953         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21954         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21955       enddo
21956 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21957        IF ( j.gt.i+1 .and.&
21958           num_conti.le.maxcont) THEN
21959 !C
21960 !C Calculate the contact function. The ith column of the array JCONT will
21961 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21962 !C greater than I). The arrays FACONT and GACONT will contain the values of
21963 !C the contact function and its derivative.
21964         r0ij=2.20D0*sigma_nucl(itypi,itypj)
21965 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21966         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21967 !c        write (2,*) "fcont",fcont
21968         if (fcont.gt.0.0D0) then
21969           num_conti=num_conti+1
21970           num_conti2=num_conti2+1
21971
21972           if (num_conti.gt.maxconts) then
21973             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21974                           ' will skip next contacts for this conf.',maxconts
21975           else
21976             jcont_hb(num_conti,i)=j
21977 !c            write (iout,*) "num_conti",num_conti,
21978 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21979 !C Calculate contact energies
21980             cosa4=4.0D0*cosa
21981             wij=cosa-3.0D0*cosb*cosg
21982             cosbg1=cosb+cosg
21983             cosbg2=cosb-cosg
21984             fac3=dsqrt(-ael6i)*r3ij
21985 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21986             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21987             if (ees0tmp.gt.0) then
21988               ees0pij=dsqrt(ees0tmp)
21989             else
21990               ees0pij=0
21991             endif
21992             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21993             if (ees0tmp.gt.0) then
21994               ees0mij=dsqrt(ees0tmp)
21995             else
21996               ees0mij=0
21997             endif
21998             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21999             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22000 !c            write (iout,*) "i",i," j",j,
22001 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22002             ees0pij1=fac3/ees0pij
22003             ees0mij1=fac3/ees0mij
22004             fac3p=-3.0D0*fac3*rrij
22005             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22006             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22007             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22008             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22009             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22010             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22011             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22012             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22013             ecosap=ecosa1+ecosa2
22014             ecosbp=ecosb1+ecosb2
22015             ecosgp=ecosg1+ecosg2
22016             ecosam=ecosa1-ecosa2
22017             ecosbm=ecosb1-ecosb2
22018             ecosgm=ecosg1-ecosg2
22019 !C End diagnostics
22020             facont_hb(num_conti,i)=fcont
22021             fprimcont=fprimcont/rij
22022             do k=1,3
22023               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22024               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22025             enddo
22026             gggp(1)=gggp(1)+ees0pijp*xj
22027             gggp(2)=gggp(2)+ees0pijp*yj
22028             gggp(3)=gggp(3)+ees0pijp*zj
22029             gggm(1)=gggm(1)+ees0mijp*xj
22030             gggm(2)=gggm(2)+ees0mijp*yj
22031             gggm(3)=gggm(3)+ees0mijp*zj
22032 !C Derivatives due to the contact function
22033             gacont_hbr(1,num_conti,i)=fprimcont*xj
22034             gacont_hbr(2,num_conti,i)=fprimcont*yj
22035             gacont_hbr(3,num_conti,i)=fprimcont*zj
22036             do k=1,3
22037 !c
22038 !c Gradient of the correlation terms
22039 !c
22040               gacontp_hb1(k,num_conti,i)= &
22041              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22042             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22043               gacontp_hb2(k,num_conti,i)= &
22044              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22045             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22046               gacontp_hb3(k,num_conti,i)=gggp(k)
22047               gacontm_hb1(k,num_conti,i)= &
22048              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22049             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22050               gacontm_hb2(k,num_conti,i)= &
22051              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22052             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22053               gacontm_hb3(k,num_conti,i)=gggm(k)
22054             enddo
22055           endif
22056         endif
22057       ENDIF
22058       return
22059       end subroutine eelsbij
22060 !------------------------------------------------------------------
22061       subroutine sc_grad_nucl
22062       use comm_locel
22063       use calc_data_nucl
22064       real(kind=8),dimension(3) :: dcosom1,dcosom2
22065       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22066       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22067       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22068       do k=1,3
22069         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22070         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22071       enddo
22072       do k=1,3
22073         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22074       enddo
22075       do k=1,3
22076         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22077                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22078                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22079         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22080                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22081                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22082       enddo
22083 !C
22084 !C Calculate the components of the gradient in DC and X
22085 !C
22086       do l=1,3
22087         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22088         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22089       enddo
22090       return
22091       end subroutine sc_grad_nucl
22092 !-----------------------------------------------------------------------
22093       subroutine esb(esbloc)
22094 !C Calculate the local energy of a side chain and its derivatives in the
22095 !C corresponding virtual-bond valence angles THETA and the spherical angles
22096 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22097 !C added by Urszula Kozlowska. 07/11/2007
22098 !C
22099       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22100       real(kind=8),dimension(9):: x
22101      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22102       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22103       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22104       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22105        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22106        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22107        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22108        integer::it,nlobit,i,j,k
22109 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22110       delta=0.02d0*pi
22111       esbloc=0.0D0
22112       do i=loc_start_nucl,loc_end_nucl
22113         if (itype(i,2).eq.ntyp1_molec(2)) cycle
22114         costtab(i+1) =dcos(theta(i+1))
22115         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22116         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22117         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22118         cosfac2=0.5d0/(1.0d0+costtab(i+1))
22119         cosfac=dsqrt(cosfac2)
22120         sinfac2=0.5d0/(1.0d0-costtab(i+1))
22121         sinfac=dsqrt(sinfac2)
22122         it=itype(i,2)
22123         if (it.eq.10) goto 1
22124
22125 !c
22126 !C  Compute the axes of tghe local cartesian coordinates system; store in
22127 !c   x_prime, y_prime and z_prime
22128 !c
22129         do j=1,3
22130           x_prime(j) = 0.00
22131           y_prime(j) = 0.00
22132           z_prime(j) = 0.00
22133         enddo
22134 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22135 !C     &   dc_norm(3,i+nres)
22136         do j = 1,3
22137           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22138           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22139         enddo
22140         do j = 1,3
22141           z_prime(j) = -uz(j,i-1)
22142 !           z_prime(j)=0.0
22143         enddo
22144
22145         xx=0.0d0
22146         yy=0.0d0
22147         zz=0.0d0
22148         do j = 1,3
22149           xx = xx + x_prime(j)*dc_norm(j,i+nres)
22150           yy = yy + y_prime(j)*dc_norm(j,i+nres)
22151           zz = zz + z_prime(j)*dc_norm(j,i+nres)
22152         enddo
22153
22154         xxtab(i)=xx
22155         yytab(i)=yy
22156         zztab(i)=zz
22157          it=itype(i,2)
22158         do j = 1,9
22159           x(j) = sc_parmin_nucl(j,it)
22160         enddo
22161 #ifdef CHECK_COORD
22162 !Cc diagnostics - remove later
22163         xx1 = dcos(alph(2))
22164         yy1 = dsin(alph(2))*dcos(omeg(2))
22165         zz1 = -dsin(alph(2))*dsin(omeg(2))
22166         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22167          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22168          xx1,yy1,zz1
22169 !C,"  --- ", xx_w,yy_w,zz_w
22170 !c end diagnostics
22171 #endif
22172         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22173         esbloc = esbloc + sumene
22174         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22175 !        print *,"enecomp",sumene,sumene2
22176 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22177 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22178 #ifdef DEBUG
22179         write (2,*) "x",(x(k),k=1,9)
22180 !C
22181 !C This section to check the numerical derivatives of the energy of ith side
22182 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22183 !C #define DEBUG in the code to turn it on.
22184 !C
22185         write (2,*) "sumene               =",sumene
22186         aincr=1.0d-7
22187         xxsave=xx
22188         xx=xx+aincr
22189         write (2,*) xx,yy,zz
22190         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22191         de_dxx_num=(sumenep-sumene)/aincr
22192         xx=xxsave
22193         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22194         yysave=yy
22195         yy=yy+aincr
22196         write (2,*) xx,yy,zz
22197         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22198         de_dyy_num=(sumenep-sumene)/aincr
22199         yy=yysave
22200         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22201         zzsave=zz
22202         zz=zz+aincr
22203         write (2,*) xx,yy,zz
22204         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22205         de_dzz_num=(sumenep-sumene)/aincr
22206         zz=zzsave
22207         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22208         costsave=cost2tab(i+1)
22209         sintsave=sint2tab(i+1)
22210         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22211         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22212         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22213         de_dt_num=(sumenep-sumene)/aincr
22214         write (2,*) " t+ sumene from enesc=",sumenep,sumene
22215         cost2tab(i+1)=costsave
22216         sint2tab(i+1)=sintsave
22217 !C End of diagnostics section.
22218 #endif
22219 !C
22220 !C Compute the gradient of esc
22221 !C
22222         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22223         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22224         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22225         de_dtt=0.0d0
22226 #ifdef DEBUG
22227         write (2,*) "x",(x(k),k=1,9)
22228         write (2,*) "xx",xx," yy",yy," zz",zz
22229         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22230           " de_zz   ",de_zz," de_tt   ",de_tt
22231         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22232           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22233 #endif
22234 !C
22235        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22236        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22237        cosfac2xx=cosfac2*xx
22238        sinfac2yy=sinfac2*yy
22239        do k = 1,3
22240          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22241            vbld_inv(i+1)
22242          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22243            vbld_inv(i)
22244          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22245          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22246 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22247 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22248 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22249 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22250          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22251          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22252          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22253          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22254          dZZ_Ci1(k)=0.0d0
22255          dZZ_Ci(k)=0.0d0
22256          do j=1,3
22257            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22258            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22259          enddo
22260
22261          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22262          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22263          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22264 !c
22265          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22266          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22267        enddo
22268
22269        do k=1,3
22270          dXX_Ctab(k,i)=dXX_Ci(k)
22271          dXX_C1tab(k,i)=dXX_Ci1(k)
22272          dYY_Ctab(k,i)=dYY_Ci(k)
22273          dYY_C1tab(k,i)=dYY_Ci1(k)
22274          dZZ_Ctab(k,i)=dZZ_Ci(k)
22275          dZZ_C1tab(k,i)=dZZ_Ci1(k)
22276          dXX_XYZtab(k,i)=dXX_XYZ(k)
22277          dYY_XYZtab(k,i)=dYY_XYZ(k)
22278          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22279        enddo
22280        do k = 1,3
22281 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22282 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22283 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22284 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22285 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22286 !c     &    dt_dci(k)
22287 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22288 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22289          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22290          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22291          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22292          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22293          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22294          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22295 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22296        enddo
22297 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22298 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22299
22300 !C to check gradient call subroutine check_grad
22301
22302     1 continue
22303       enddo
22304       return
22305       end subroutine esb
22306 !=-------------------------------------------------------
22307       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22308 !      implicit none
22309       real(kind=8),dimension(9):: x(9)
22310        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22311       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22312       integer i
22313 !c      write (2,*) "enesc"
22314 !c      write (2,*) "x",(x(i),i=1,9)
22315 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22316       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22317         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22318         + x(9)*yy*zz
22319       enesc_nucl=sumene
22320       return
22321       end function enesc_nucl
22322 !-----------------------------------------------------------------------------
22323       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22324 #ifdef MPI
22325       include 'mpif.h'
22326       integer,parameter :: max_cont=2000
22327       integer,parameter:: max_dim=2*(8*3+6)
22328       integer, parameter :: msglen1=max_cont*max_dim
22329       integer,parameter :: msglen2=2*msglen1
22330       integer source,CorrelType,CorrelID,Error
22331       real(kind=8) :: buffer(max_cont,max_dim)
22332       integer status(MPI_STATUS_SIZE)
22333       integer :: ierror,nbytes
22334 #endif
22335       real(kind=8),dimension(3):: gx(3),gx1(3)
22336       real(kind=8) :: time00
22337       logical lprn,ldone
22338       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22339       real(kind=8) ecorr,ecorr3
22340       integer :: n_corr,n_corr1,mm,msglen
22341 !C Set lprn=.true. for debugging
22342       lprn=.false.
22343       n_corr=0
22344       n_corr1=0
22345 #ifdef MPI
22346       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22347
22348       if (nfgtasks.le.1) goto 30
22349       if (lprn) then
22350         write (iout,'(a)') 'Contact function values:'
22351         do i=nnt,nct-1
22352           write (iout,'(2i3,50(1x,i2,f5.2))')  &
22353          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22354          j=1,num_cont_hb(i))
22355         enddo
22356       endif
22357 !C Caution! Following code assumes that electrostatic interactions concerning
22358 !C a given atom are split among at most two processors!
22359       CorrelType=477
22360       CorrelID=fg_rank+1
22361       ldone=.false.
22362       do i=1,max_cont
22363         do j=1,max_dim
22364           buffer(i,j)=0.0D0
22365         enddo
22366       enddo
22367       mm=mod(fg_rank,2)
22368 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22369       if (mm) 20,20,10
22370    10 continue
22371 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22372       if (fg_rank.gt.0) then
22373 !C Send correlation contributions to the preceding processor
22374         msglen=msglen1
22375         nn=num_cont_hb(iatel_s_nucl)
22376         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22377 !c        write (*,*) 'The BUFFER array:'
22378 !c        do i=1,nn
22379 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22380 !c        enddo
22381         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22382           msglen=msglen2
22383           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22384 !C Clear the contacts of the atom passed to the neighboring processor
22385         nn=num_cont_hb(iatel_s_nucl+1)
22386 !c        do i=1,nn
22387 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22388 !c        enddo
22389             num_cont_hb(iatel_s_nucl)=0
22390         endif
22391 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22392 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22393 !cd   & ' msglen=',msglen
22394 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22395 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22396 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22397         time00=MPI_Wtime()
22398         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22399          CorrelType,FG_COMM,IERROR)
22400         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22401 !cd      write (iout,*) 'Processor ',fg_rank,
22402 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22403 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22404 !c        write (*,*) 'Processor ',fg_rank,
22405 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22406 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22407 !c        msglen=msglen1
22408       endif ! (fg_rank.gt.0)
22409       if (ldone) goto 30
22410       ldone=.true.
22411    20 continue
22412 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22413       if (fg_rank.lt.nfgtasks-1) then
22414 !C Receive correlation contributions from the next processor
22415         msglen=msglen1
22416         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22417 !cd      write (iout,*) 'Processor',fg_rank,
22418 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22419 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22420 !c        write (*,*) 'Processor',fg_rank,
22421 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22422 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22423         time00=MPI_Wtime()
22424         nbytes=-1
22425         do while (nbytes.le.0)
22426           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22427           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22428         enddo
22429 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22430         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22431          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22432         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22433 !c        write (*,*) 'Processor',fg_rank,
22434 !c     &' has received correlation contribution from processor',fg_rank+1,
22435 !c     & ' msglen=',msglen,' nbytes=',nbytes
22436 !c        write (*,*) 'The received BUFFER array:'
22437 !c        do i=1,max_cont
22438 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22439 !c        enddo
22440         if (msglen.eq.msglen1) then
22441           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22442         else if (msglen.eq.msglen2)  then
22443           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22444           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22445         else
22446           write (iout,*) &
22447       'ERROR!!!! message length changed while processing correlations.'
22448           write (*,*) &
22449       'ERROR!!!! message length changed while processing correlations.'
22450           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22451         endif ! msglen.eq.msglen1
22452       endif ! fg_rank.lt.nfgtasks-1
22453       if (ldone) goto 30
22454       ldone=.true.
22455       goto 10
22456    30 continue
22457 #endif
22458       if (lprn) then
22459         write (iout,'(a)') 'Contact function values:'
22460         do i=nnt_molec(2),nct_molec(2)-1
22461           write (iout,'(2i3,50(1x,i2,f5.2))') &
22462          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22463          j=1,num_cont_hb(i))
22464         enddo
22465       endif
22466       ecorr=0.0D0
22467       ecorr3=0.0d0
22468 !C Remove the loop below after debugging !!!
22469 !      do i=nnt_molec(2),nct_molec(2)
22470 !        do j=1,3
22471 !          gradcorr_nucl(j,i)=0.0D0
22472 !          gradxorr_nucl(j,i)=0.0D0
22473 !          gradcorr3_nucl(j,i)=0.0D0
22474 !          gradxorr3_nucl(j,i)=0.0D0
22475 !        enddo
22476 !      enddo
22477 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22478 !C Calculate the local-electrostatic correlation terms
22479       do i=iatsc_s_nucl,iatsc_e_nucl
22480         i1=i+1
22481         num_conti=num_cont_hb(i)
22482         num_conti1=num_cont_hb(i+1)
22483 !        print *,i,num_conti,num_conti1
22484         do jj=1,num_conti
22485           j=jcont_hb(jj,i)
22486           do kk=1,num_conti1
22487             j1=jcont_hb(kk,i1)
22488 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22489 !c     &         ' jj=',jj,' kk=',kk
22490             if (j1.eq.j+1 .or. j1.eq.j-1) then
22491 !C
22492 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22493 !C The system gains extra energy.
22494 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22495 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22496 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22497 !C
22498               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22499               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22500                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22501               n_corr=n_corr+1
22502             else if (j1.eq.j) then
22503 !C
22504 !C Contacts I-J and I-(J+1) occur simultaneously.
22505 !C The system loses extra energy.
22506 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22507 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22508 !C Need to implement full formulas 32 from Liwo et al., 1998.
22509 !C
22510 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22511 !c     &         ' jj=',jj,' kk=',kk
22512               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22513             endif
22514           enddo ! kk
22515           do kk=1,num_conti
22516             j1=jcont_hb(kk,i)
22517 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22518 !c     &         ' jj=',jj,' kk=',kk
22519             if (j1.eq.j+1) then
22520 !C Contacts I-J and (I+1)-J occur simultaneously.
22521 !C The system loses extra energy.
22522               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22523             endif ! j1==j+1
22524           enddo ! kk
22525         enddo ! jj
22526       enddo ! i
22527       return
22528       end subroutine multibody_hb_nucl
22529 !-----------------------------------------------------------
22530       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22531 !      implicit real*8 (a-h,o-z)
22532 !      include 'DIMENSIONS'
22533 !      include 'COMMON.IOUNITS'
22534 !      include 'COMMON.DERIV'
22535 !      include 'COMMON.INTERACT'
22536 !      include 'COMMON.CONTACTS'
22537       real(kind=8),dimension(3) :: gx,gx1
22538       logical :: lprn
22539 !el local variables
22540       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22541       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22542                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22543                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22544                    rlocshield
22545
22546       lprn=.false.
22547       eij=facont_hb(jj,i)
22548       ekl=facont_hb(kk,k)
22549       ees0pij=ees0p(jj,i)
22550       ees0pkl=ees0p(kk,k)
22551       ees0mij=ees0m(jj,i)
22552       ees0mkl=ees0m(kk,k)
22553       ekont=eij*ekl
22554       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22555 !      print *,"ehbcorr_nucl",ekont,ees
22556 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22557 !C Following 4 lines for diagnostics.
22558 !cd    ees0pkl=0.0D0
22559 !cd    ees0pij=1.0D0
22560 !cd    ees0mkl=0.0D0
22561 !cd    ees0mij=1.0D0
22562 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22563 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22564 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22565 !C Calculate the multi-body contribution to energy.
22566 !      ecorr_nucl=ecorr_nucl+ekont*ees
22567 !C Calculate multi-body contributions to the gradient.
22568       coeffpees0pij=coeffp*ees0pij
22569       coeffmees0mij=coeffm*ees0mij
22570       coeffpees0pkl=coeffp*ees0pkl
22571       coeffmees0mkl=coeffm*ees0mkl
22572       do ll=1,3
22573         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22574        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22575        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22576         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22577         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22578         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22579         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22580         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22581         coeffmees0mij*gacontm_hb1(ll,kk,k))
22582         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22583         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22584         coeffmees0mij*gacontm_hb2(ll,kk,k))
22585         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22586           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22587           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22588         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22589         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22590         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22591           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22592           coeffmees0mij*gacontm_hb3(ll,kk,k))
22593         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22594         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22595         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22596         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22597         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22598         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22599       enddo
22600       ehbcorr_nucl=ekont*ees
22601       return
22602       end function ehbcorr_nucl
22603 !-------------------------------------------------------------------------
22604
22605      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22606 !      implicit real*8 (a-h,o-z)
22607 !      include 'DIMENSIONS'
22608 !      include 'COMMON.IOUNITS'
22609 !      include 'COMMON.DERIV'
22610 !      include 'COMMON.INTERACT'
22611 !      include 'COMMON.CONTACTS'
22612       real(kind=8),dimension(3) :: gx,gx1
22613       logical :: lprn
22614 !el local variables
22615       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22616       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22617                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22618                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22619                    rlocshield
22620
22621       lprn=.false.
22622       eij=facont_hb(jj,i)
22623       ekl=facont_hb(kk,k)
22624       ees0pij=ees0p(jj,i)
22625       ees0pkl=ees0p(kk,k)
22626       ees0mij=ees0m(jj,i)
22627       ees0mkl=ees0m(kk,k)
22628       ekont=eij*ekl
22629       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22630 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22631 !C Following 4 lines for diagnostics.
22632 !cd    ees0pkl=0.0D0
22633 !cd    ees0pij=1.0D0
22634 !cd    ees0mkl=0.0D0
22635 !cd    ees0mij=1.0D0
22636 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22637 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22638 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22639 !C Calculate the multi-body contribution to energy.
22640 !      ecorr=ecorr+ekont*ees
22641 !C Calculate multi-body contributions to the gradient.
22642       coeffpees0pij=coeffp*ees0pij
22643       coeffmees0mij=coeffm*ees0mij
22644       coeffpees0pkl=coeffp*ees0pkl
22645       coeffmees0mkl=coeffm*ees0mkl
22646       do ll=1,3
22647         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22648        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22649        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22650         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22651         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22652         coeffmees0mkl*gacontm_hb2(ll,jj,i))
22653         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22654         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22655         coeffmees0mij*gacontm_hb1(ll,kk,k))
22656         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22657         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22658         coeffmees0mij*gacontm_hb2(ll,kk,k))
22659         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22660           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22661           coeffmees0mkl*gacontm_hb3(ll,jj,i))
22662         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22663         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22664         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22665           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22666           coeffmees0mij*gacontm_hb3(ll,kk,k))
22667         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22668         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22669         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22670         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22671         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22672         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22673       enddo
22674       ehbcorr3_nucl=ekont*ees
22675       return
22676       end function ehbcorr3_nucl
22677 #ifdef MPI
22678       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22679       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22680       real(kind=8):: buffer(dimen1,dimen2)
22681       num_kont=num_cont_hb(atom)
22682       do i=1,num_kont
22683         do k=1,8
22684           do j=1,3
22685             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22686           enddo ! j
22687         enddo ! k
22688         buffer(i,indx+25)=facont_hb(i,atom)
22689         buffer(i,indx+26)=ees0p(i,atom)
22690         buffer(i,indx+27)=ees0m(i,atom)
22691         buffer(i,indx+28)=d_cont(i,atom)
22692         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22693       enddo ! i
22694       buffer(1,indx+30)=dfloat(num_kont)
22695       return
22696       end subroutine pack_buffer
22697 !c------------------------------------------------------------------------------
22698       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22699       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22700       real(kind=8):: buffer(dimen1,dimen2)
22701 !      double precision zapas
22702 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22703 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22704 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22705 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22706       num_kont=buffer(1,indx+30)
22707       num_kont_old=num_cont_hb(atom)
22708       num_cont_hb(atom)=num_kont+num_kont_old
22709       do i=1,num_kont
22710         ii=i+num_kont_old
22711         do k=1,8
22712           do j=1,3
22713             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22714           enddo ! j
22715         enddo ! k
22716         facont_hb(ii,atom)=buffer(i,indx+25)
22717         ees0p(ii,atom)=buffer(i,indx+26)
22718         ees0m(ii,atom)=buffer(i,indx+27)
22719         d_cont(i,atom)=buffer(i,indx+28)
22720         jcont_hb(ii,atom)=buffer(i,indx+29)
22721       enddo ! i
22722       return
22723       end subroutine unpack_buffer
22724 !c------------------------------------------------------------------------------
22725 #endif
22726       subroutine ecatcat(ecationcation)
22727         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22728         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22729         r7,r4,ecationcation,k0,rcal
22730         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22731         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22732         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22733         gg,r
22734
22735         ecationcation=0.0d0
22736         if (nres_molec(5).eq.0) return
22737         rcat0=3.472
22738         epscalc=0.05
22739         r06 = rcat0**6
22740         r012 = r06**2
22741 !        k0 = 332.0*(2.0*2.0)/80.0
22742         itmp=0
22743
22744         do i=1,4
22745         itmp=itmp+nres_molec(i)
22746         enddo
22747 !        write(iout,*) "itmp",itmp
22748         do i=itmp+1,itmp+nres_molec(5)-1
22749
22750         xi=c(1,i)
22751         yi=c(2,i)
22752         zi=c(3,i)
22753 !        write (iout,*) i,"TUTUT",c(1,i)
22754           itypi=itype(i,5)
22755           xi=mod(xi,boxxsize)
22756           if (xi.lt.0) xi=xi+boxxsize
22757           yi=mod(yi,boxysize)
22758           if (yi.lt.0) yi=yi+boxysize
22759           zi=mod(zi,boxzsize)
22760           if (zi.lt.0) zi=zi+boxzsize
22761
22762           do j=i+1,itmp+nres_molec(5)
22763           itypj=itype(j,5)
22764 !          print *,i,j,itypi,itypj
22765           k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22766 !           print *,i,j,'catcat'
22767            xj=c(1,j)
22768            yj=c(2,j)
22769            zj=c(3,j)
22770           xj=dmod(xj,boxxsize)
22771           if (xj.lt.0) xj=xj+boxxsize
22772           yj=dmod(yj,boxysize)
22773           if (yj.lt.0) yj=yj+boxysize
22774           zj=dmod(zj,boxzsize)
22775           if (zj.lt.0) zj=zj+boxzsize
22776 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22777       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22778       xj_safe=xj
22779       yj_safe=yj
22780       zj_safe=zj
22781       subchap=0
22782       do xshift=-1,1
22783       do yshift=-1,1
22784       do zshift=-1,1
22785           xj=xj_safe+xshift*boxxsize
22786           yj=yj_safe+yshift*boxysize
22787           zj=zj_safe+zshift*boxzsize
22788           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22789           if(dist_temp.lt.dist_init) then
22790             dist_init=dist_temp
22791             xj_temp=xj
22792             yj_temp=yj
22793             zj_temp=zj
22794             subchap=1
22795           endif
22796        enddo
22797        enddo
22798        enddo
22799        if (subchap.eq.1) then
22800           xj=xj_temp-xi
22801           yj=yj_temp-yi
22802           zj=zj_temp-zi
22803        else
22804           xj=xj_safe-xi
22805           yj=yj_safe-yi
22806           zj=zj_safe-zi
22807        endif
22808        rcal =xj**2+yj**2+zj**2
22809         ract=sqrt(rcal)
22810 !        rcat0=3.472
22811 !        epscalc=0.05
22812 !        r06 = rcat0**6
22813 !        r012 = r06**2
22814 !        k0 = 332*(2*2)/80
22815         Evan1cat=epscalc*(r012/(rcal**6))
22816         Evan2cat=epscalc*2*(r06/(rcal**3))
22817         Eeleccat=k0/ract
22818         r7 = rcal**7
22819         r4 = rcal**4
22820         r(1)=xj
22821         r(2)=yj
22822         r(3)=zj
22823         do k=1,3
22824           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22825           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22826           dEeleccat(k)=-k0*r(k)/ract**3
22827         enddo
22828         do k=1,3
22829           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22830           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22831           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22832         enddo
22833         if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22834          r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22835 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22836         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22837        enddo
22838        enddo
22839        return
22840        end subroutine ecatcat
22841 !---------------------------------------------------------------------------
22842 ! new for K+
22843       subroutine ecats_prot_amber(evdw)
22844 !      subroutine ecat_prot2(ecation_prot)
22845       use calc_data
22846       use comm_momo
22847
22848       logical :: lprn
22849 !el local variables
22850       integer :: iint,itypi1,subchap,isel,itmp
22851       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22852       real(kind=8) :: evdw
22853       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22854                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22855                     sslipi,sslipj,faclip,alpha_sco
22856       integer :: ii
22857       real(kind=8) :: fracinbuf
22858       real (kind=8) :: escpho
22859       real (kind=8),dimension(4):: ener
22860       real(kind=8) :: b1,b2,egb
22861       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22862        Lambf,&
22863        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22864        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22865        federmaus,&
22866        d1i,d1j
22867 !       real(kind=8),dimension(3,2)::erhead_tail
22868 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22869       real(kind=8) ::  facd4, adler, Fgb, facd3
22870       integer troll,jj,istate
22871       real (kind=8) :: dcosom1(3),dcosom2(3)
22872
22873       evdw=0.0D0
22874       if (nres_molec(5).eq.0) return
22875       eps_out=80.0d0
22876 !      sss_ele_cut=1.0d0
22877
22878         itmp=0
22879         do i=1,4
22880         itmp=itmp+nres_molec(i)
22881         enddo
22882 !        go to 17
22883 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22884         do i=ibond_start,ibond_end
22885
22886 !        print *,"I am in EVDW",i
22887         itypi=iabs(itype(i,1))
22888
22889 !        if (i.ne.47) cycle
22890         if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22891         itypi1=iabs(itype(i+1,1))
22892         xi=c(1,nres+i)
22893         yi=c(2,nres+i)
22894         zi=c(3,nres+i)
22895           xi=dmod(xi,boxxsize)
22896           if (xi.lt.0) xi=xi+boxxsize
22897           yi=dmod(yi,boxysize)
22898           if (yi.lt.0) yi=yi+boxysize
22899           zi=dmod(zi,boxzsize)
22900           if (zi.lt.0) zi=zi+boxzsize
22901         dxi=dc_norm(1,nres+i)
22902         dyi=dc_norm(2,nres+i)
22903         dzi=dc_norm(3,nres+i)
22904         dsci_inv=vbld_inv(i+nres)
22905          do j=itmp+1,itmp+nres_molec(5)
22906
22907 ! Calculate SC interaction energy.
22908             itypj=iabs(itype(j,5))
22909             if ((itypj.eq.ntyp1)) cycle
22910              CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22911
22912             dscj_inv=0.0
22913            xj=c(1,j)
22914            yj=c(2,j)
22915            zj=c(3,j)
22916            xj=dmod(xj,boxxsize)
22917            if (xj.lt.0) xj=xj+boxxsize
22918            yj=dmod(yj,boxysize)
22919            if (yj.lt.0) yj=yj+boxysize
22920            zj=dmod(zj,boxzsize)
22921            if (zj.lt.0) zj=zj+boxzsize
22922           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22923           xj_safe=xj
22924           yj_safe=yj
22925           zj_safe=zj
22926           subchap=0
22927
22928           do xshift=-1,1
22929           do yshift=-1,1
22930           do zshift=-1,1
22931           xj=xj_safe+xshift*boxxsize
22932           yj=yj_safe+yshift*boxysize
22933           zj=zj_safe+zshift*boxzsize
22934           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22935           if(dist_temp.lt.dist_init) then
22936             dist_init=dist_temp
22937             xj_temp=xj
22938             yj_temp=yj
22939             zj_temp=zj
22940             subchap=1
22941           endif
22942           enddo
22943           enddo
22944           enddo
22945           if (subchap.eq.1) then
22946           xj=xj_temp-xi
22947           yj=yj_temp-yi
22948           zj=zj_temp-zi
22949           else
22950           xj=xj_safe-xi
22951           yj=yj_safe-yi
22952           zj=zj_safe-zi
22953           endif
22954
22955 !          dxj = dc_norm( 1, nres+j )
22956 !          dyj = dc_norm( 2, nres+j )
22957 !          dzj = dc_norm( 3, nres+j )
22958
22959           itypi = itype(i,1)
22960           itypj = itype(j,5)
22961 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22962 ! sampling performed with amber package
22963 !          alf1   = 0.0d0
22964 !          alf2   = 0.0d0
22965 !          alf12  = 0.0d0
22966 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22967           chi1 = chi1cat(itypi,itypj)
22968           chis1 = chis1cat(itypi,itypj)
22969           chip1 = chipp1cat(itypi,itypj)
22970 !          chi1=0.0d0
22971 !          chis1=0.0d0
22972 !          chip1=0.0d0
22973           chi2=0.0
22974           chip2=0.0
22975           chis2=0.0
22976 !          chis2 = chis(itypj,itypi)
22977           chis12 = chis1 * chis2
22978           sig1 = sigmap1cat(itypi,itypj)
22979 !          sig2 = sigmap2(itypi,itypj)
22980 ! alpha factors from Fcav/Gcav
22981           b1cav = alphasurcat(1,itypi,itypj)
22982           b2cav = alphasurcat(2,itypi,itypj)
22983           b3cav = alphasurcat(3,itypi,itypj)
22984           b4cav = alphasurcat(4,itypi,itypj)
22985
22986 ! used to determine whether we want to do quadrupole calculations
22987        eps_in = epsintabcat(itypi,itypj)
22988        if (eps_in.eq.0.0) eps_in=1.0
22989
22990        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22991 !       Rtail = 0.0d0
22992
22993        DO k = 1, 3
22994         ctail(k,1)=c(k,i+nres)
22995         ctail(k,2)=c(k,j)
22996        END DO
22997 !c! tail distances will be themselves usefull elswhere
22998 !c1 (in Gcav, for example)
22999        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
23000        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
23001        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
23002        Rtail = dsqrt( &
23003           (Rtail_distance(1)*Rtail_distance(1)) &
23004         + (Rtail_distance(2)*Rtail_distance(2)) &
23005         + (Rtail_distance(3)*Rtail_distance(3)))
23006 ! tail location and distance calculations
23007 ! dhead1
23008        d1 = dheadcat(1, 1, itypi, itypj)
23009 !       d2 = dhead(2, 1, itypi, itypj)
23010        DO k = 1,3
23011 ! location of polar head is computed by taking hydrophobic centre
23012 ! and moving by a d1 * dc_norm vector
23013 ! see unres publications for very informative images
23014         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23015         chead(k,2) = c(k, j)
23016 ! distance
23017 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23018 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23019         Rhead_distance(k) = chead(k,2) - chead(k,1)
23020        END DO
23021 ! pitagoras (root of sum of squares)
23022        Rhead = dsqrt( &
23023           (Rhead_distance(1)*Rhead_distance(1)) &
23024         + (Rhead_distance(2)*Rhead_distance(2)) &
23025         + (Rhead_distance(3)*Rhead_distance(3)))
23026 !-------------------------------------------------------------------
23027 ! zero everything that should be zero'ed
23028        evdwij = 0.0d0
23029        ECL = 0.0d0
23030        Elj = 0.0d0
23031        Equad = 0.0d0
23032        Epol = 0.0d0
23033        Fcav=0.0d0
23034        eheadtail = 0.0d0
23035        dGCLdOM1 = 0.0d0
23036        dGCLdOM2 = 0.0d0
23037        dGCLdOM12 = 0.0d0
23038        dPOLdOM1 = 0.0d0
23039        dPOLdOM2 = 0.0d0
23040           Fcav = 0.0d0
23041           dFdR = 0.0d0
23042           dCAVdOM1  = 0.0d0
23043           dCAVdOM2  = 0.0d0
23044           dCAVdOM12 = 0.0d0
23045           dscj_inv = vbld_inv(j+nres)
23046 !          print *,i,j,dscj_inv,dsci_inv
23047 ! rij holds 1/(distance of Calpha atoms)
23048           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23049           rij  = dsqrt(rrij)
23050           CALL sc_angular
23051 ! this should be in elgrad_init but om's are calculated by sc_angular
23052 ! which in turn is used by older potentials
23053 ! om = omega, sqom = om^2
23054           sqom1  = om1 * om1
23055           sqom2  = om2 * om2
23056           sqom12 = om12 * om12
23057
23058 ! now we calculate EGB - Gey-Berne
23059 ! It will be summed up in evdwij and saved in evdw
23060           sigsq     = 1.0D0  / sigsq
23061           sig       = sig0ij * dsqrt(sigsq)
23062 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23063           rij_shift = Rtail - sig + sig0ij
23064           IF (rij_shift.le.0.0D0) THEN
23065            evdw = 1.0D20
23066            RETURN
23067           END IF
23068           sigder = -sig * sigsq
23069           rij_shift = 1.0D0 / rij_shift
23070           fac       = rij_shift**expon
23071           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23072 !          print *,"ADAM",aa_aq(itypi,itypj)
23073
23074 !          c1        = 0.0d0
23075           c2        = fac  * bb_aq_cat(itypi,itypj)
23076 !          c2        = 0.0d0
23077           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23078           eps2der   = eps3rt * evdwij
23079           eps3der   = eps2rt * evdwij
23080 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23081           evdwij    = eps2rt * eps3rt * evdwij
23082 !#ifdef TSCSC
23083 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23084 !           evdw_p = evdw_p + evdwij
23085 !          ELSE
23086 !           evdw_m = evdw_m + evdwij
23087 !          END IF
23088 !#else
23089           evdw = evdw  &
23090               + evdwij
23091 !#endif
23092           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23093           fac    = -expon * (c1 + evdwij) * rij_shift
23094           sigder = fac * sigder
23095 ! Calculate distance derivative
23096           gg(1) =  fac
23097           gg(2) =  fac
23098           gg(3) =  fac
23099
23100           fac = chis1 * sqom1 + chis2 * sqom2 &
23101           - 2.0d0 * chis12 * om1 * om2 * om12
23102           pom = 1.0d0 - chis1 * chis2 * sqom12
23103           Lambf = (1.0d0 - (fac / pom))
23104           Lambf = dsqrt(Lambf)
23105           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23106           Chif = Rtail * sparrow
23107           ChiLambf = Chif * Lambf
23108           eagle = dsqrt(ChiLambf)
23109           bat = ChiLambf ** 11.0d0
23110           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23111           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23112           botsq = bot * bot
23113           Fcav = top / bot
23114
23115        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23116        dbot = 12.0d0 * b4cav * bat * Lambf
23117        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23118
23119           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23120           dbot = 12.0d0 * b4cav * bat * Chif
23121           eagle = Lambf * pom
23122           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23123           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23124           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23125               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23126
23127           dFdL = ((dtop * bot - top * dbot) / botsq)
23128           dCAVdOM1  = dFdL * ( dFdOM1 )
23129           dCAVdOM2  = dFdL * ( dFdOM2 )
23130           dCAVdOM12 = dFdL * ( dFdOM12 )
23131
23132        DO k= 1, 3
23133         ertail(k) = Rtail_distance(k)/Rtail
23134        END DO
23135        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23136        erdxj = scalar( ertail(1), dC_norm(1,j) )
23137        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23138        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23139        DO k = 1, 3
23140         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23141         gradpepcatx(k,i) = gradpepcatx(k,i) &
23142                   - (( dFdR + gg(k) ) * pom)
23143         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23144 !        gvdwx(k,j) = gvdwx(k,j)   &
23145 !                  + (( dFdR + gg(k) ) * pom)
23146         gradpepcat(k,i) = gradpepcat(k,i)  &
23147                   - (( dFdR + gg(k) ) * ertail(k))
23148         gradpepcat(k,j) = gradpepcat(k,j) &
23149                   + (( dFdR + gg(k) ) * ertail(k))
23150         gg(k) = 0.0d0
23151        ENDDO
23152 !c! Compute head-head and head-tail energies for each state
23153           isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
23154           IF (isel.eq.0) THEN
23155 !c! No charges - do nothing
23156            eheadtail = 0.0d0
23157
23158           ELSE IF (isel.eq.1) THEN
23159 !c! Nonpolar-charge interactions
23160           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23161             Qi=Qi*2
23162             Qij=Qij*2
23163            endif
23164           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23165             Qj=Qj*2
23166             Qij=Qij*2
23167            endif
23168
23169            CALL enq_cat(epol)
23170            eheadtail = epol
23171 !           eheadtail = 0.0d0
23172
23173           ELSE IF (isel.eq.3) THEN
23174 !c! Dipole-charge interactions
23175           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23176             Qi=Qi*2
23177             Qij=Qij*2
23178            endif
23179           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23180             Qj=Qj*2
23181             Qij=Qij*2
23182            endif
23183            write(iout,*) "KURWA0",d1
23184
23185            CALL edq_cat(ecl, elj, epol)
23186           eheadtail = ECL + elj + epol
23187 !           eheadtail = 0.0d0
23188
23189           ELSE IF ((isel.eq.2)) THEN
23190
23191 !c! Same charge-charge interaction ( +/+ or -/- )
23192           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23193             Qi=Qi*2
23194             Qij=Qij*2
23195            endif
23196           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23197             Qj=Qj*2
23198             Qij=Qij*2
23199            endif
23200
23201            CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23202            eheadtail = ECL + Egb + Epol + Fisocav + Elj
23203 !           eheadtail = 0.0d0
23204
23205 !          ELSE IF ((isel.eq.2.and.  &
23206 !               iabs(Qi).eq.1).and. &
23207 !               nstate(itypi,itypj).ne.1) THEN
23208 !c! Different charge-charge interaction ( +/- or -/+ )
23209 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23210 !            Qi=Qi*2
23211 !            Qij=Qij*2
23212 !           endif
23213 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23214 !            Qj=Qj*2
23215 !            Qij=Qij*2
23216 !           endif
23217 !
23218 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23219        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23220         evdw = evdw  + Fcav + eheadtail
23221
23222        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23223         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23224         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23225         Equad,evdwij+Fcav+eheadtail,evdw
23226 !       evdw = evdw  + Fcav  + eheadtail
23227
23228 !        iF (nstate(itypi,itypj).eq.1) THEN
23229         CALL sc_grad_cat
23230 !       END IF
23231 !c!-------------------------------------------------------------------
23232 !c! NAPISY KONCOWE
23233          END DO   ! j
23234        END DO     ! i
23235 !c      write (iout,*) "Number of loop steps in EGB:",ind
23236 !c      energy_dec=.false.
23237 !              print *,"EVDW KURW",evdw,nres
23238 !!!        return
23239    17   continue
23240         do i=ibond_start,ibond_end
23241
23242 !        print *,"I am in EVDW",i
23243         itypi=10 ! the peptide group parameters are for glicine
23244
23245 !        if (i.ne.47) cycle
23246         if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
23247         itypi1=iabs(itype(i+1,1))
23248         xi=(c(1,i)+c(1,i+1))/2.0
23249         yi=(c(2,i)+c(2,i+1))/2.0
23250         zi=(c(3,i)+c(3,i+1))/2.0
23251           xi=dmod(xi,boxxsize)
23252           if (xi.lt.0) xi=xi+boxxsize
23253           yi=dmod(yi,boxysize)
23254           if (yi.lt.0) yi=yi+boxysize
23255           zi=dmod(zi,boxzsize)
23256           if (zi.lt.0) zi=zi+boxzsize
23257         dxi=dc_norm(1,i)
23258         dyi=dc_norm(2,i)
23259         dzi=dc_norm(3,i)
23260         dsci_inv=vbld_inv(i+1)/2.0
23261          do j=itmp+1,itmp+nres_molec(5)
23262
23263 ! Calculate SC interaction energy.
23264             itypj=iabs(itype(j,5))
23265             if ((itypj.eq.ntyp1)) cycle
23266              CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23267
23268             dscj_inv=0.0
23269            xj=c(1,j)
23270            yj=c(2,j)
23271            zj=c(3,j)
23272            xj=dmod(xj,boxxsize)
23273            if (xj.lt.0) xj=xj+boxxsize
23274            yj=dmod(yj,boxysize)
23275            if (yj.lt.0) yj=yj+boxysize
23276            zj=dmod(zj,boxzsize)
23277            if (zj.lt.0) zj=zj+boxzsize
23278           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23279           xj_safe=xj
23280           yj_safe=yj
23281           zj_safe=zj
23282           subchap=0
23283
23284           do xshift=-1,1
23285           do yshift=-1,1
23286           do zshift=-1,1
23287           xj=xj_safe+xshift*boxxsize
23288           yj=yj_safe+yshift*boxysize
23289           zj=zj_safe+zshift*boxzsize
23290           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23291           if(dist_temp.lt.dist_init) then
23292             dist_init=dist_temp
23293             xj_temp=xj
23294             yj_temp=yj
23295             zj_temp=zj
23296             subchap=1
23297           endif
23298           enddo
23299           enddo
23300           enddo
23301           if (subchap.eq.1) then
23302           xj=xj_temp-xi
23303           yj=yj_temp-yi
23304           zj=zj_temp-zi
23305           else
23306           xj=xj_safe-xi
23307           yj=yj_safe-yi
23308           zj=zj_safe-zi
23309           endif
23310
23311           dxj = 0.0d0! dc_norm( 1, nres+j )
23312           dyj = 0.0d0!dc_norm( 2, nres+j )
23313           dzj = 0.0d0! dc_norm( 3, nres+j )
23314
23315           itypi = 10
23316           itypj = itype(j,5)
23317 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23318 ! sampling performed with amber package
23319 !          alf1   = 0.0d0
23320 !          alf2   = 0.0d0
23321 !          alf12  = 0.0d0
23322 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23323           chi1 = chi1cat(itypi,itypj)
23324           chis1 = chis1cat(itypi,itypj)
23325           chip1 = chipp1cat(itypi,itypj)
23326 !          chi1=0.0d0
23327 !          chis1=0.0d0
23328 !          chip1=0.0d0
23329           chi2=0.0
23330           chip2=0.0
23331           chis2=0.0
23332 !          chis2 = chis(itypj,itypi)
23333           chis12 = chis1 * chis2
23334           sig1 = sigmap1cat(itypi,itypj)
23335 !          sig2 = sigmap2(itypi,itypj)
23336 ! alpha factors from Fcav/Gcav
23337           b1cav = alphasurcat(1,itypi,itypj)
23338           b2cav = alphasurcat(2,itypi,itypj)
23339           b3cav = alphasurcat(3,itypi,itypj)
23340           b4cav = alphasurcat(4,itypi,itypj)
23341
23342 ! used to determine whether we want to do quadrupole calculations
23343        eps_in = epsintabcat(itypi,itypj)
23344        if (eps_in.eq.0.0) eps_in=1.0
23345
23346        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23347 !       Rtail = 0.0d0
23348
23349        DO k = 1, 3
23350         ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
23351         ctail(k,2)=c(k,j)
23352        END DO
23353 !c! tail distances will be themselves usefull elswhere
23354 !c1 (in Gcav, for example)
23355        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
23356        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
23357        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
23358        Rtail = dsqrt( &
23359           (Rtail_distance(1)*Rtail_distance(1)) &
23360         + (Rtail_distance(2)*Rtail_distance(2)) &
23361         + (Rtail_distance(3)*Rtail_distance(3)))
23362 ! tail location and distance calculations
23363 ! dhead1
23364        d1 = dheadcat(1, 1, itypi, itypj)
23365 !       print *,"d1",d1
23366 !       d1=0.0d0
23367 !       d2 = dhead(2, 1, itypi, itypj)
23368        DO k = 1,3
23369 ! location of polar head is computed by taking hydrophobic centre
23370 ! and moving by a d1 * dc_norm vector
23371 ! see unres publications for very informative images
23372         chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
23373         chead(k,2) = c(k, j)
23374 ! distance
23375 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23376 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23377         Rhead_distance(k) = chead(k,2) - chead(k,1)
23378        END DO
23379 ! pitagoras (root of sum of squares)
23380        Rhead = dsqrt( &
23381           (Rhead_distance(1)*Rhead_distance(1)) &
23382         + (Rhead_distance(2)*Rhead_distance(2)) &
23383         + (Rhead_distance(3)*Rhead_distance(3)))
23384 !-------------------------------------------------------------------
23385 ! zero everything that should be zero'ed
23386        evdwij = 0.0d0
23387        ECL = 0.0d0
23388        Elj = 0.0d0
23389        Equad = 0.0d0
23390        Epol = 0.0d0
23391        Fcav=0.0d0
23392        eheadtail = 0.0d0
23393        dGCLdOM1 = 0.0d0
23394        dGCLdOM2 = 0.0d0
23395        dGCLdOM12 = 0.0d0
23396        dPOLdOM1 = 0.0d0
23397        dPOLdOM2 = 0.0d0
23398           Fcav = 0.0d0
23399           dFdR = 0.0d0
23400           dCAVdOM1  = 0.0d0
23401           dCAVdOM2  = 0.0d0
23402           dCAVdOM12 = 0.0d0
23403           dscj_inv = vbld_inv(j+nres)
23404 !          print *,i,j,dscj_inv,dsci_inv
23405 ! rij holds 1/(distance of Calpha atoms)
23406           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23407           rij  = dsqrt(rrij)
23408           CALL sc_angular
23409 ! this should be in elgrad_init but om's are calculated by sc_angular
23410 ! which in turn is used by older potentials
23411 ! om = omega, sqom = om^2
23412           sqom1  = om1 * om1
23413           sqom2  = om2 * om2
23414           sqom12 = om12 * om12
23415
23416 ! now we calculate EGB - Gey-Berne
23417 ! It will be summed up in evdwij and saved in evdw
23418           sigsq     = 1.0D0  / sigsq
23419           sig       = sig0ij * dsqrt(sigsq)
23420 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23421           rij_shift = Rtail - sig + sig0ij
23422           IF (rij_shift.le.0.0D0) THEN
23423            evdw = 1.0D20
23424            RETURN
23425           END IF
23426           sigder = -sig * sigsq
23427           rij_shift = 1.0D0 / rij_shift
23428           fac       = rij_shift**expon
23429           c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23430 !          print *,"ADAM",aa_aq(itypi,itypj)
23431
23432 !          c1        = 0.0d0
23433           c2        = fac  * bb_aq_cat(itypi,itypj)
23434 !          c2        = 0.0d0
23435           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23436           eps2der   = eps3rt * evdwij
23437           eps3der   = eps2rt * evdwij
23438 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23439           evdwij    = eps2rt * eps3rt * evdwij
23440 !#ifdef TSCSC
23441 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23442 !           evdw_p = evdw_p + evdwij
23443 !          ELSE
23444 !           evdw_m = evdw_m + evdwij
23445 !          END IF
23446 !#else
23447           evdw = evdw  &
23448               + evdwij
23449 !#endif
23450           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23451           fac    = -expon * (c1 + evdwij) * rij_shift
23452           sigder = fac * sigder
23453 ! Calculate distance derivative
23454           gg(1) =  fac
23455           gg(2) =  fac
23456           gg(3) =  fac
23457
23458           fac = chis1 * sqom1 + chis2 * sqom2 &
23459           - 2.0d0 * chis12 * om1 * om2 * om12
23460
23461           pom = 1.0d0 - chis1 * chis2 * sqom12
23462 !          print *,"TUT2",fac,chis1,sqom1,pom
23463           Lambf = (1.0d0 - (fac / pom))
23464           Lambf = dsqrt(Lambf)
23465           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23466           Chif = Rtail * sparrow
23467           ChiLambf = Chif * Lambf
23468           eagle = dsqrt(ChiLambf)
23469           bat = ChiLambf ** 11.0d0
23470           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23471           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23472           botsq = bot * bot
23473           Fcav = top / bot
23474
23475        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23476        dbot = 12.0d0 * b4cav * bat * Lambf
23477        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23478
23479           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23480           dbot = 12.0d0 * b4cav * bat * Chif
23481           eagle = Lambf * pom
23482           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23483           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23484           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23485               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23486
23487           dFdL = ((dtop * bot - top * dbot) / botsq)
23488           dCAVdOM1  = dFdL * ( dFdOM1 )
23489           dCAVdOM2  = dFdL * ( dFdOM2 )
23490           dCAVdOM12 = dFdL * ( dFdOM12 )
23491
23492        DO k= 1, 3
23493         ertail(k) = Rtail_distance(k)/Rtail
23494        END DO
23495        erdxi = scalar( ertail(1), dC_norm(1,i) )
23496        erdxj = scalar( ertail(1), dC_norm(1,j) )
23497        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
23498        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23499        DO k = 1, 3
23500         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
23501 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
23502 !                  - (( dFdR + gg(k) ) * pom)
23503         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23504 !        gvdwx(k,j) = gvdwx(k,j)   &
23505 !                  + (( dFdR + gg(k) ) * pom)
23506         gradpepcat(k,i) = gradpepcat(k,i)  &
23507                   - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23508         gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
23509                   - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23510
23511         gradpepcat(k,j) = gradpepcat(k,j) &
23512                   + (( dFdR + gg(k) ) * ertail(k))
23513         gg(k) = 0.0d0
23514        ENDDO
23515 !c! Compute head-head and head-tail energies for each state
23516           isel = 3
23517 !c! Dipole-charge interactions
23518           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23519             Qi=Qi*2
23520             Qij=Qij*2
23521            endif
23522           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23523             Qj=Qj*2
23524             Qij=Qij*2
23525            endif
23526            CALL edq_cat_pep(ecl, elj, epol)
23527            eheadtail = ECL + elj + epol
23528 !          print *,"i,",i,eheadtail
23529 !           eheadtail = 0.0d0
23530
23531         evdw = evdw  + Fcav + eheadtail
23532
23533        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23534         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23535         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23536         Equad,evdwij+Fcav+eheadtail,evdw
23537 !       evdw = evdw  + Fcav  + eheadtail
23538
23539 !        iF (nstate(itypi,itypj).eq.1) THEN
23540         CALL sc_grad_cat_pep
23541 !       END IF
23542 !c!-------------------------------------------------------------------
23543 !c! NAPISY KONCOWE
23544          END DO   ! j
23545        END DO     ! i
23546 !c      write (iout,*) "Number of loop steps in EGB:",ind
23547 !c      energy_dec=.false.
23548 !              print *,"EVDW KURW",evdw,nres
23549
23550
23551       return
23552       end subroutine ecats_prot_amber
23553
23554 !---------------------------------------------------------------------------
23555 ! old for Ca2+
23556        subroutine ecat_prot(ecation_prot)
23557 !      use calc_data
23558 !      use comm_momo
23559        integer i,j,k,subchap,itmp,inum
23560         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23561         r7,r4,ecationcation
23562         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23563         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23564         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23565         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23566         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23567         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23568         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23569         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23570         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23571         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23572         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23573         ndiv,ndivi
23574         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23575         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23576         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23577         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23578         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23579         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23580         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23581         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23582         dEvan1Cat
23583         real(kind=8),dimension(6) :: vcatprm
23584         ecation_prot=0.0d0
23585 ! first lets calculate interaction with peptide groups
23586         if (nres_molec(5).eq.0) return
23587         itmp=0
23588         do i=1,4
23589         itmp=itmp+nres_molec(i)
23590         enddo
23591 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23592         do i=ibond_start,ibond_end
23593 !         cycle
23594          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23595         xi=0.5d0*(c(1,i)+c(1,i+1))
23596         yi=0.5d0*(c(2,i)+c(2,i+1))
23597         zi=0.5d0*(c(3,i)+c(3,i+1))
23598           xi=mod(xi,boxxsize)
23599           if (xi.lt.0) xi=xi+boxxsize
23600           yi=mod(yi,boxysize)
23601           if (yi.lt.0) yi=yi+boxysize
23602           zi=mod(zi,boxzsize)
23603           if (zi.lt.0) zi=zi+boxzsize
23604
23605          do j=itmp+1,itmp+nres_molec(5)
23606 !           print *,"WTF",itmp,j,i
23607 ! all parameters were for Ca2+ to approximate single charge divide by two
23608          ndiv=1.0
23609          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23610          wconst=78*ndiv
23611         wdip =1.092777950857032D2
23612         wdip=wdip/wconst
23613         wmodquad=-2.174122713004870D4
23614         wmodquad=wmodquad/wconst
23615         wquad1 = 3.901232068562804D1
23616         wquad1=wquad1/wconst
23617         wquad2 = 3
23618         wquad2=wquad2/wconst
23619         wvan1 = 0.1
23620         wvan2 = 6
23621 !        itmp=0
23622
23623            xj=c(1,j)
23624            yj=c(2,j)
23625            zj=c(3,j)
23626           xj=dmod(xj,boxxsize)
23627           if (xj.lt.0) xj=xj+boxxsize
23628           yj=dmod(yj,boxysize)
23629           if (yj.lt.0) yj=yj+boxysize
23630           zj=dmod(zj,boxzsize)
23631           if (zj.lt.0) zj=zj+boxzsize
23632       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23633       xj_safe=xj
23634       yj_safe=yj
23635       zj_safe=zj
23636       subchap=0
23637       do xshift=-1,1
23638       do yshift=-1,1
23639       do zshift=-1,1
23640           xj=xj_safe+xshift*boxxsize
23641           yj=yj_safe+yshift*boxysize
23642           zj=zj_safe+zshift*boxzsize
23643           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23644           if(dist_temp.lt.dist_init) then
23645             dist_init=dist_temp
23646             xj_temp=xj
23647             yj_temp=yj
23648             zj_temp=zj
23649             subchap=1
23650           endif
23651        enddo
23652        enddo
23653        enddo
23654        if (subchap.eq.1) then
23655           xj=xj_temp-xi
23656           yj=yj_temp-yi
23657           zj=zj_temp-zi
23658        else
23659           xj=xj_safe-xi
23660           yj=yj_safe-yi
23661           zj=zj_safe-zi
23662        endif
23663 !       enddo
23664 !       enddo
23665        rcpm = sqrt(xj**2+yj**2+zj**2)
23666        drcp_norm(1)=xj/rcpm
23667        drcp_norm(2)=yj/rcpm
23668        drcp_norm(3)=zj/rcpm
23669        dcmag=0.0
23670        do k=1,3
23671        dcmag=dcmag+dc(k,i)**2
23672        enddo
23673        dcmag=dsqrt(dcmag)
23674        do k=1,3
23675          myd_norm(k)=dc(k,i)/dcmag
23676        enddo
23677         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23678         drcp_norm(3)*myd_norm(3)
23679         rsecp = rcpm**2
23680         Ir = 1.0d0/rcpm
23681         Irsecp = 1.0d0/rsecp
23682         Irthrp = Irsecp/rcpm
23683         Irfourp = Irthrp/rcpm
23684         Irfiftp = Irfourp/rcpm
23685         Irsistp=Irfiftp/rcpm
23686         Irseven=Irsistp/rcpm
23687         Irtwelv=Irsistp*Irsistp
23688         Irthir=Irtwelv/rcpm
23689         sin2thet = (1-costhet*costhet)
23690         sinthet=sqrt(sin2thet)
23691         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23692              *sin2thet
23693         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23694              2*wvan2**6*Irsistp)
23695         ecation_prot = ecation_prot+E1+E2
23696 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23697         dE1dr = -2*costhet*wdip*Irthrp-&
23698          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23699         dE2dr = 3*wquad1*wquad2*Irfourp-     &
23700           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23701         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23702         do k=1,3
23703           drdpep(k) = -drcp_norm(k)
23704           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23705           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23706           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23707           dEddci(k) = dEdcos*dcosddci(k)
23708         enddo
23709         do k=1,3
23710         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23711         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23712         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23713         enddo
23714        enddo ! j
23715        enddo ! i
23716 !------------------------------------------sidechains
23717 !        do i=1,nres_molec(1)
23718         do i=ibond_start,ibond_end
23719          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23720 !         cycle
23721 !        print *,i,ecation_prot
23722         xi=(c(1,i+nres))
23723         yi=(c(2,i+nres))
23724         zi=(c(3,i+nres))
23725           xi=mod(xi,boxxsize)
23726           if (xi.lt.0) xi=xi+boxxsize
23727           yi=mod(yi,boxysize)
23728           if (yi.lt.0) yi=yi+boxysize
23729           zi=mod(zi,boxzsize)
23730           if (zi.lt.0) zi=zi+boxzsize
23731           do k=1,3
23732             cm1(k)=dc(k,i+nres)
23733           enddo
23734            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23735          do j=itmp+1,itmp+nres_molec(5)
23736          ndiv=1.0
23737          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23738
23739            xj=c(1,j)
23740            yj=c(2,j)
23741            zj=c(3,j)
23742           xj=dmod(xj,boxxsize)
23743           if (xj.lt.0) xj=xj+boxxsize
23744           yj=dmod(yj,boxysize)
23745           if (yj.lt.0) yj=yj+boxysize
23746           zj=dmod(zj,boxzsize)
23747           if (zj.lt.0) zj=zj+boxzsize
23748       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23749       xj_safe=xj
23750       yj_safe=yj
23751       zj_safe=zj
23752       subchap=0
23753       do xshift=-1,1
23754       do yshift=-1,1
23755       do zshift=-1,1
23756           xj=xj_safe+xshift*boxxsize
23757           yj=yj_safe+yshift*boxysize
23758           zj=zj_safe+zshift*boxzsize
23759           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23760           if(dist_temp.lt.dist_init) then
23761             dist_init=dist_temp
23762             xj_temp=xj
23763             yj_temp=yj
23764             zj_temp=zj
23765             subchap=1
23766           endif
23767        enddo
23768        enddo
23769        enddo
23770        if (subchap.eq.1) then
23771           xj=xj_temp-xi
23772           yj=yj_temp-yi
23773           zj=zj_temp-zi
23774        else
23775           xj=xj_safe-xi
23776           yj=yj_safe-yi
23777           zj=zj_safe-zi
23778        endif
23779 !       enddo
23780 !       enddo
23781 ! 15- Glu 16-Asp
23782          if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23783          ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23784          (itype(i,1).eq.25))) then
23785             if(itype(i,1).eq.16) then
23786             inum=1
23787             else
23788             inum=2
23789             endif
23790             do k=1,6
23791             vcatprm(k)=catprm(k,inum)
23792             enddo
23793             dASGL=catprm(7,inum)
23794 !             do k=1,3
23795 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23796                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23797                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23798                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23799
23800 !                valpha(k)=c(k,i)
23801 !                vcat(k)=c(k,j)
23802                 if (subchap.eq.1) then
23803                  vcat(1)=xj_temp
23804                  vcat(2)=yj_temp
23805                  vcat(3)=zj_temp
23806                  else
23807                 vcat(1)=xj_safe
23808                 vcat(2)=yj_safe
23809                 vcat(3)=zj_safe
23810                  endif
23811                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23812                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23813                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23814
23815 !              enddo
23816         do k=1,3
23817           dx(k) = vcat(k)-vcm(k)
23818         enddo
23819         do k=1,3
23820           v1(k)=(vcm(k)-valpha(k))
23821           v2(k)=(vcat(k)-valpha(k))
23822         enddo
23823         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23824         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23825         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23826
23827 !  The weights of the energy function calculated from
23828 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23829           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23830             ndivi=0.5
23831           else
23832             ndivi=1.0
23833           endif
23834          ndiv=1.0
23835          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23836
23837         wh2o=78*ndivi*ndiv
23838         wc = vcatprm(1)
23839         wc=wc/wh2o
23840         wdip =vcatprm(2)
23841         wdip=wdip/wh2o
23842         wquad1 =vcatprm(3)
23843         wquad1=wquad1/wh2o
23844         wquad2 = vcatprm(4)
23845         wquad2=wquad2/wh2o
23846         wquad2p = 1.0d0-wquad2
23847         wvan1 = vcatprm(5)
23848         wvan2 =vcatprm(6)
23849         opt = dx(1)**2+dx(2)**2
23850         rsecp = opt+dx(3)**2
23851         rs = sqrt(rsecp)
23852         rthrp = rsecp*rs
23853         rfourp = rthrp*rs
23854         rsixp = rfourp*rsecp
23855         reight=rsixp*rsecp
23856         Ir = 1.0d0/rs
23857         Irsecp = 1.0d0/rsecp
23858         Irthrp = Irsecp/rs
23859         Irfourp = Irthrp/rs
23860         Irsixp = 1.0d0/rsixp
23861         Ireight=1.0d0/reight
23862         Irtw=Irsixp*Irsixp
23863         Irthir=Irtw/rs
23864         Irfourt=Irthir/rs
23865         opt1 = (4*rs*dx(3)*wdip)
23866         opt2 = 6*rsecp*wquad1*opt
23867         opt3 = wquad1*wquad2p*Irsixp
23868         opt4 = (wvan1*wvan2**12)
23869         opt5 = opt4*12*Irfourt
23870         opt6 = 2*wvan1*wvan2**6
23871         opt7 = 6*opt6*Ireight
23872         opt8 = wdip/v1m
23873         opt10 = wdip/v2m
23874         opt11 = (rsecp*v2m)**2
23875         opt12 = (rsecp*v1m)**2
23876         opt14 = (v1m*v2m*rsecp)**2
23877         opt15 = -wquad1/v2m**2
23878         opt16 = (rthrp*(v1m*v2m)**2)**2
23879         opt17 = (v1m**2*rthrp)**2
23880         opt18 = -wquad1/rthrp
23881         opt19 = (v1m**2*v2m**2)**2
23882         Ec = wc*Ir
23883         do k=1,3
23884           dEcCat(k) = -(dx(k)*wc)*Irthrp
23885           dEcCm(k)=(dx(k)*wc)*Irthrp
23886           dEcCalp(k)=0.0d0
23887         enddo
23888         Edip=opt8*(v1dpv2)/(rsecp*v2m)
23889         do k=1,3
23890           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23891                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23892           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23893                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23894           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23895                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23896                       *v1dpv2)/opt14
23897         enddo
23898         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23899         do k=1,3
23900           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23901                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23902                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23903           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23904                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23905                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23906           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23907                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23908                         v1dpv2**2)/opt19
23909         enddo
23910         Equad2=wquad1*wquad2p*Irthrp
23911         do k=1,3
23912           dEquad2Cat(k)=-3*dx(k)*rs*opt3
23913           dEquad2Cm(k)=3*dx(k)*rs*opt3
23914           dEquad2Calp(k)=0.0d0
23915         enddo
23916         Evan1=opt4*Irtw
23917         do k=1,3
23918           dEvan1Cat(k)=-dx(k)*opt5
23919           dEvan1Cm(k)=dx(k)*opt5
23920           dEvan1Calp(k)=0.0d0
23921         enddo
23922         Evan2=-opt6*Irsixp
23923         do k=1,3
23924           dEvan2Cat(k)=dx(k)*opt7
23925           dEvan2Cm(k)=-dx(k)*opt7
23926           dEvan2Calp(k)=0.0d0
23927         enddo
23928         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23929 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23930
23931         do k=1,3
23932           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23933                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23934 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23935           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23936                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23937           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23938                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23939         enddo
23940             dscmag = 0.0d0
23941             do k=1,3
23942               dscvec(k) = dc(k,i+nres)
23943               dscmag = dscmag+dscvec(k)*dscvec(k)
23944             enddo
23945             dscmag3 = dscmag
23946             dscmag = sqrt(dscmag)
23947             dscmag3 = dscmag3*dscmag
23948             constA = 1.0d0+dASGL/dscmag
23949             constB = 0.0d0
23950             do k=1,3
23951               constB = constB+dscvec(k)*dEtotalCm(k)
23952             enddo
23953             constB = constB*dASGL/dscmag3
23954             do k=1,3
23955               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23956               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23957                constA*dEtotalCm(k)-constB*dscvec(k)
23958 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23959               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23960               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23961              enddo
23962         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23963            if(itype(i,1).eq.14) then
23964             inum=3
23965             else
23966             inum=4
23967             endif
23968             do k=1,6
23969             vcatprm(k)=catprm(k,inum)
23970             enddo
23971             dASGL=catprm(7,inum)
23972 !             do k=1,3
23973 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23974 !                valpha(k)=c(k,i)
23975 !                vcat(k)=c(k,j)
23976 !              enddo
23977                 vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23978                 vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23979                 vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23980                 if (subchap.eq.1) then
23981                  vcat(1)=xj_temp
23982                  vcat(2)=yj_temp
23983                  vcat(3)=zj_temp
23984                  else
23985                 vcat(1)=xj_safe
23986                 vcat(2)=yj_safe
23987                 vcat(3)=zj_safe
23988                 endif
23989                 valpha(1)=xi-c(1,i+nres)+c(1,i)
23990                 valpha(2)=yi-c(2,i+nres)+c(2,i)
23991                 valpha(3)=zi-c(3,i+nres)+c(3,i)
23992
23993
23994         do k=1,3
23995           dx(k) = vcat(k)-vcm(k)
23996         enddo
23997         do k=1,3
23998           v1(k)=(vcm(k)-valpha(k))
23999           v2(k)=(vcat(k)-valpha(k))
24000         enddo
24001         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24002         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24003         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24004 !  The weights of the energy function calculated from
24005 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
24006          ndiv=1.0
24007          if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24008
24009         wh2o=78*ndiv
24010         wdip =vcatprm(2)
24011         wdip=wdip/wh2o
24012         wquad1 =vcatprm(3)
24013         wquad1=wquad1/wh2o
24014         wquad2 = vcatprm(4)
24015         wquad2=wquad2/wh2o
24016         wquad2p = 1-wquad2
24017         wvan1 = vcatprm(5)
24018         wvan2 =vcatprm(6)
24019         opt = dx(1)**2+dx(2)**2
24020         rsecp = opt+dx(3)**2
24021         rs = sqrt(rsecp)
24022         rthrp = rsecp*rs
24023         rfourp = rthrp*rs
24024         rsixp = rfourp*rsecp
24025         reight=rsixp*rsecp
24026         Ir = 1.0d0/rs
24027         Irsecp = 1/rsecp
24028         Irthrp = Irsecp/rs
24029         Irfourp = Irthrp/rs
24030         Irsixp = 1/rsixp
24031         Ireight=1/reight
24032         Irtw=Irsixp*Irsixp
24033         Irthir=Irtw/rs
24034         Irfourt=Irthir/rs
24035         opt1 = (4*rs*dx(3)*wdip)
24036         opt2 = 6*rsecp*wquad1*opt
24037         opt3 = wquad1*wquad2p*Irsixp
24038         opt4 = (wvan1*wvan2**12)
24039         opt5 = opt4*12*Irfourt
24040         opt6 = 2*wvan1*wvan2**6
24041         opt7 = 6*opt6*Ireight
24042         opt8 = wdip/v1m
24043         opt10 = wdip/v2m
24044         opt11 = (rsecp*v2m)**2
24045         opt12 = (rsecp*v1m)**2
24046         opt14 = (v1m*v2m*rsecp)**2
24047         opt15 = -wquad1/v2m**2
24048         opt16 = (rthrp*(v1m*v2m)**2)**2
24049         opt17 = (v1m**2*rthrp)**2
24050         opt18 = -wquad1/rthrp
24051         opt19 = (v1m**2*v2m**2)**2
24052         Edip=opt8*(v1dpv2)/(rsecp*v2m)
24053         do k=1,3
24054           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24055                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24056          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24057                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24058           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24059                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24060                       *v1dpv2)/opt14
24061         enddo
24062         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24063         do k=1,3
24064           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24065                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24066                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24067           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24068                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24069                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24070           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24071                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24072                         v1dpv2**2)/opt19
24073         enddo
24074         Equad2=wquad1*wquad2p*Irthrp
24075         do k=1,3
24076           dEquad2Cat(k)=-3*dx(k)*rs*opt3
24077           dEquad2Cm(k)=3*dx(k)*rs*opt3
24078           dEquad2Calp(k)=0.0d0
24079         enddo
24080         Evan1=opt4*Irtw
24081         do k=1,3
24082           dEvan1Cat(k)=-dx(k)*opt5
24083           dEvan1Cm(k)=dx(k)*opt5
24084           dEvan1Calp(k)=0.0d0
24085         enddo
24086         Evan2=-opt6*Irsixp
24087         do k=1,3
24088           dEvan2Cat(k)=dx(k)*opt7
24089           dEvan2Cm(k)=-dx(k)*opt7
24090           dEvan2Calp(k)=0.0d0
24091         enddo
24092          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24093         do k=1,3
24094           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24095                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24096           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24097                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24098           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24099                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24100         enddo
24101             dscmag = 0.0d0
24102             do k=1,3
24103               dscvec(k) = c(k,i+nres)-c(k,i)
24104 ! TU SPRAWDZ???
24105 !              dscvec(1) = xj
24106 !              dscvec(2) = yj
24107 !              dscvec(3) = zj
24108
24109               dscmag = dscmag+dscvec(k)*dscvec(k)
24110             enddo
24111             dscmag3 = dscmag
24112             dscmag = sqrt(dscmag)
24113             dscmag3 = dscmag3*dscmag
24114             constA = 1+dASGL/dscmag
24115             constB = 0.0d0
24116             do k=1,3
24117               constB = constB+dscvec(k)*dEtotalCm(k)
24118             enddo
24119             constB = constB*dASGL/dscmag3
24120             do k=1,3
24121               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24122               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24123                constA*dEtotalCm(k)-constB*dscvec(k)
24124               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24125               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24126              enddo
24127            else
24128             rcal = 0.0d0
24129             do k=1,3
24130 !              r(k) = c(k,j)-c(k,i+nres)
24131               r(1) = xj
24132               r(2) = yj
24133               r(3) = zj
24134               rcal = rcal+r(k)*r(k)
24135             enddo
24136             ract=sqrt(rcal)
24137             rocal=1.5
24138             epscalc=0.2
24139             r0p=0.5*(rocal+sig0(itype(i,1)))
24140             r06 = r0p**6
24141             r012 = r06*r06
24142             Evan1=epscalc*(r012/rcal**6)
24143             Evan2=epscalc*2*(r06/rcal**3)
24144             r4 = rcal**4
24145             r7 = rcal**7
24146             do k=1,3
24147               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24148               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24149             enddo
24150             do k=1,3
24151               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24152             enddo
24153                  ecation_prot = ecation_prot+ Evan1+Evan2
24154             do  k=1,3
24155                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24156                dEtotalCm(k)
24157               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24158               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24159              enddo
24160          endif ! 13-16 residues
24161        enddo !j
24162        enddo !i
24163        return
24164        end subroutine ecat_prot
24165
24166 !----------------------------------------------------------------------------
24167 !-----------------------------------------------------------------------------
24168 !-----------------------------------------------------------------------------
24169       subroutine eprot_sc_base(escbase)
24170       use calc_data
24171 !      implicit real*8 (a-h,o-z)
24172 !      include 'DIMENSIONS'
24173 !      include 'COMMON.GEO'
24174 !      include 'COMMON.VAR'
24175 !      include 'COMMON.LOCAL'
24176 !      include 'COMMON.CHAIN'
24177 !      include 'COMMON.DERIV'
24178 !      include 'COMMON.NAMES'
24179 !      include 'COMMON.INTERACT'
24180 !      include 'COMMON.IOUNITS'
24181 !      include 'COMMON.CALC'
24182 !      include 'COMMON.CONTROL'
24183 !      include 'COMMON.SBRIDGE'
24184       logical :: lprn
24185 !el local variables
24186       integer :: iint,itypi,itypi1,itypj,subchap
24187       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24188       real(kind=8) :: evdw,sig0ij
24189       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24190                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24191                     sslipi,sslipj,faclip
24192       integer :: ii
24193       real(kind=8) :: fracinbuf
24194        real (kind=8) :: escbase
24195        real (kind=8),dimension(4):: ener
24196        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24197        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24198         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24199         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24200         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24201         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24202         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24203         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24204        real(kind=8),dimension(3,2)::chead,erhead_tail
24205        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24206        integer troll
24207        eps_out=80.0d0
24208        escbase=0.0d0
24209 !       do i=1,nres_molec(1)
24210         do i=ibond_start,ibond_end
24211         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24212         itypi  = itype(i,1)
24213         dxi    = dc_norm(1,nres+i)
24214         dyi    = dc_norm(2,nres+i)
24215         dzi    = dc_norm(3,nres+i)
24216         dsci_inv = vbld_inv(i+nres)
24217         xi=c(1,nres+i)
24218         yi=c(2,nres+i)
24219         zi=c(3,nres+i)
24220         xi=mod(xi,boxxsize)
24221          if (xi.lt.0) xi=xi+boxxsize
24222         yi=mod(yi,boxysize)
24223          if (yi.lt.0) yi=yi+boxysize
24224         zi=mod(zi,boxzsize)
24225          if (zi.lt.0) zi=zi+boxzsize
24226          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24227            itypj= itype(j,2)
24228            if (itype(j,2).eq.ntyp1_molec(2))cycle
24229            xj=c(1,j+nres)
24230            yj=c(2,j+nres)
24231            zj=c(3,j+nres)
24232            xj=dmod(xj,boxxsize)
24233            if (xj.lt.0) xj=xj+boxxsize
24234            yj=dmod(yj,boxysize)
24235            if (yj.lt.0) yj=yj+boxysize
24236            zj=dmod(zj,boxzsize)
24237            if (zj.lt.0) zj=zj+boxzsize
24238           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24239           xj_safe=xj
24240           yj_safe=yj
24241           zj_safe=zj
24242           subchap=0
24243
24244           do xshift=-1,1
24245           do yshift=-1,1
24246           do zshift=-1,1
24247           xj=xj_safe+xshift*boxxsize
24248           yj=yj_safe+yshift*boxysize
24249           zj=zj_safe+zshift*boxzsize
24250           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24251           if(dist_temp.lt.dist_init) then
24252             dist_init=dist_temp
24253             xj_temp=xj
24254             yj_temp=yj
24255             zj_temp=zj
24256             subchap=1
24257           endif
24258           enddo
24259           enddo
24260           enddo
24261           if (subchap.eq.1) then
24262           xj=xj_temp-xi
24263           yj=yj_temp-yi
24264           zj=zj_temp-zi
24265           else
24266           xj=xj_safe-xi
24267           yj=yj_safe-yi
24268           zj=zj_safe-zi
24269           endif
24270           dxj = dc_norm( 1, nres+j )
24271           dyj = dc_norm( 2, nres+j )
24272           dzj = dc_norm( 3, nres+j )
24273 !          print *,i,j,itypi,itypj
24274           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
24275           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
24276 !          d1i=0.0d0
24277 !          d1j=0.0d0
24278 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24279 ! Gay-berne var's
24280           sig0ij = sigma_scbase( itypi,itypj )
24281           chi1   = chi_scbase( itypi, itypj,1 )
24282           chi2   = chi_scbase( itypi, itypj,2 )
24283 !          chi1=0.0d0
24284 !          chi2=0.0d0
24285           chi12  = chi1 * chi2
24286           chip1  = chipp_scbase( itypi, itypj,1 )
24287           chip2  = chipp_scbase( itypi, itypj,2 )
24288 !          chip1=0.0d0
24289 !          chip2=0.0d0
24290           chip12 = chip1 * chip2
24291 ! not used by momo potential, but needed by sc_angular which is shared
24292 ! by all energy_potential subroutines
24293           alf1   = 0.0d0
24294           alf2   = 0.0d0
24295           alf12  = 0.0d0
24296           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
24297 !       a12sq = a12sq * a12sq
24298 ! charge of amino acid itypi is...
24299           chis1 = chis_scbase(itypi,itypj,1)
24300           chis2 = chis_scbase(itypi,itypj,2)
24301           chis12 = chis1 * chis2
24302           sig1 = sigmap1_scbase(itypi,itypj)
24303           sig2 = sigmap2_scbase(itypi,itypj)
24304 !       write (*,*) "sig1 = ", sig1
24305 !       write (*,*) "sig2 = ", sig2
24306 ! alpha factors from Fcav/Gcav
24307           b1 = alphasur_scbase(1,itypi,itypj)
24308 !          b1=0.0d0
24309           b2 = alphasur_scbase(2,itypi,itypj)
24310           b3 = alphasur_scbase(3,itypi,itypj)
24311           b4 = alphasur_scbase(4,itypi,itypj)
24312 ! used to determine whether we want to do quadrupole calculations
24313 ! used by Fgb
24314        eps_in = epsintab_scbase(itypi,itypj)
24315        if (eps_in.eq.0.0) eps_in=1.0
24316        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24317 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24318 !-------------------------------------------------------------------
24319 ! tail location and distance calculations
24320        DO k = 1,3
24321 ! location of polar head is computed by taking hydrophobic centre
24322 ! and moving by a d1 * dc_norm vector
24323 ! see unres publications for very informative images
24324         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24325         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
24326 ! distance
24327 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24328 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24329         Rhead_distance(k) = chead(k,2) - chead(k,1)
24330        END DO
24331 ! pitagoras (root of sum of squares)
24332        Rhead = dsqrt( &
24333           (Rhead_distance(1)*Rhead_distance(1)) &
24334         + (Rhead_distance(2)*Rhead_distance(2)) &
24335         + (Rhead_distance(3)*Rhead_distance(3)))
24336 !-------------------------------------------------------------------
24337 ! zero everything that should be zero'ed
24338        evdwij = 0.0d0
24339        ECL = 0.0d0
24340        Elj = 0.0d0
24341        Equad = 0.0d0
24342        Epol = 0.0d0
24343        Fcav=0.0d0
24344        eheadtail = 0.0d0
24345        dGCLdOM1 = 0.0d0
24346        dGCLdOM2 = 0.0d0
24347        dGCLdOM12 = 0.0d0
24348        dPOLdOM1 = 0.0d0
24349        dPOLdOM2 = 0.0d0
24350           Fcav = 0.0d0
24351           dFdR = 0.0d0
24352           dCAVdOM1  = 0.0d0
24353           dCAVdOM2  = 0.0d0
24354           dCAVdOM12 = 0.0d0
24355           dscj_inv = vbld_inv(j+nres)
24356 !          print *,i,j,dscj_inv,dsci_inv
24357 ! rij holds 1/(distance of Calpha atoms)
24358           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24359           rij  = dsqrt(rrij)
24360 !----------------------------
24361           CALL sc_angular
24362 ! this should be in elgrad_init but om's are calculated by sc_angular
24363 ! which in turn is used by older potentials
24364 ! om = omega, sqom = om^2
24365           sqom1  = om1 * om1
24366           sqom2  = om2 * om2
24367           sqom12 = om12 * om12
24368
24369 ! now we calculate EGB - Gey-Berne
24370 ! It will be summed up in evdwij and saved in evdw
24371           sigsq     = 1.0D0  / sigsq
24372           sig       = sig0ij * dsqrt(sigsq)
24373 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24374           rij_shift = 1.0/rij - sig + sig0ij
24375           IF (rij_shift.le.0.0D0) THEN
24376            evdw = 1.0D20
24377            RETURN
24378           END IF
24379           sigder = -sig * sigsq
24380           rij_shift = 1.0D0 / rij_shift
24381           fac       = rij_shift**expon
24382           c1        = fac  * fac * aa_scbase(itypi,itypj)
24383 !          c1        = 0.0d0
24384           c2        = fac  * bb_scbase(itypi,itypj)
24385 !          c2        = 0.0d0
24386           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24387           eps2der   = eps3rt * evdwij
24388           eps3der   = eps2rt * evdwij
24389 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24390           evdwij    = eps2rt * eps3rt * evdwij
24391           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24392           fac    = -expon * (c1 + evdwij) * rij_shift
24393           sigder = fac * sigder
24394 !          fac    = rij * fac
24395 ! Calculate distance derivative
24396           gg(1) =  fac
24397           gg(2) =  fac
24398           gg(3) =  fac
24399 !          if (b2.gt.0.0) then
24400           fac = chis1 * sqom1 + chis2 * sqom2 &
24401           - 2.0d0 * chis12 * om1 * om2 * om12
24402 ! we will use pom later in Gcav, so dont mess with it!
24403           pom = 1.0d0 - chis1 * chis2 * sqom12
24404           Lambf = (1.0d0 - (fac / pom))
24405           Lambf = dsqrt(Lambf)
24406           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24407 !       write (*,*) "sparrow = ", sparrow
24408           Chif = 1.0d0/rij * sparrow
24409           ChiLambf = Chif * Lambf
24410           eagle = dsqrt(ChiLambf)
24411           bat = ChiLambf ** 11.0d0
24412           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24413           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24414           botsq = bot * bot
24415           Fcav = top / bot
24416 !          print *,i,j,Fcav
24417           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24418           dbot = 12.0d0 * b4 * bat * Lambf
24419           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24420 !       dFdR = 0.0d0
24421 !      write (*,*) "dFcav/dR = ", dFdR
24422           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24423           dbot = 12.0d0 * b4 * bat * Chif
24424           eagle = Lambf * pom
24425           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24426           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24427           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24428               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24429
24430           dFdL = ((dtop * bot - top * dbot) / botsq)
24431 !       dFdL = 0.0d0
24432           dCAVdOM1  = dFdL * ( dFdOM1 )
24433           dCAVdOM2  = dFdL * ( dFdOM2 )
24434           dCAVdOM12 = dFdL * ( dFdOM12 )
24435
24436           ertail(1) = xj*rij
24437           ertail(2) = yj*rij
24438           ertail(3) = zj*rij
24439 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24440 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24441 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24442 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24443 !           print *,"EOMY",eom1,eom2,eom12
24444 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24445 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24446 ! here dtail=0.0
24447 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24448 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24449        DO k = 1, 3
24450 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24451 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24452         pom = ertail(k)
24453 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24454         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24455                   - (( dFdR + gg(k) ) * pom)
24456 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24457 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24458 !     &             - ( dFdR * pom )
24459         pom = ertail(k)
24460 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24461         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24462                   + (( dFdR + gg(k) ) * pom)
24463 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24464 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24465 !c!     &             + ( dFdR * pom )
24466
24467         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24468                   - (( dFdR + gg(k) ) * ertail(k))
24469 !c!     &             - ( dFdR * ertail(k))
24470
24471         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24472                   + (( dFdR + gg(k) ) * ertail(k))
24473 !c!     &             + ( dFdR * ertail(k))
24474
24475         gg(k) = 0.0d0
24476 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24477 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24478       END DO
24479
24480 !          else
24481
24482 !          endif
24483 !Now dipole-dipole
24484          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24485        w1 = wdipdip_scbase(1,itypi,itypj)
24486        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24487        w3 = wdipdip_scbase(2,itypi,itypj)
24488 !c!-------------------------------------------------------------------
24489 !c! ECL
24490        fac = (om12 - 3.0d0 * om1 * om2)
24491        c1 = (w1 / (Rhead**3.0d0)) * fac
24492        c2 = (w2 / Rhead ** 6.0d0)  &
24493          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24494        c3= (w3/ Rhead ** 6.0d0)  &
24495          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24496        ECL = c1 - c2 + c3
24497 !c!       write (*,*) "w1 = ", w1
24498 !c!       write (*,*) "w2 = ", w2
24499 !c!       write (*,*) "om1 = ", om1
24500 !c!       write (*,*) "om2 = ", om2
24501 !c!       write (*,*) "om12 = ", om12
24502 !c!       write (*,*) "fac = ", fac
24503 !c!       write (*,*) "c1 = ", c1
24504 !c!       write (*,*) "c2 = ", c2
24505 !c!       write (*,*) "Ecl = ", Ecl
24506 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24507 !c!       write (*,*) "c2_2 = ",
24508 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24509 !c!-------------------------------------------------------------------
24510 !c! dervative of ECL is GCL...
24511 !c! dECL/dr
24512        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24513        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24514          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24515        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24516          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24517        dGCLdR = c1 - c2 + c3
24518 !c! dECL/dom1
24519        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24520        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24521          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24522        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24523        dGCLdOM1 = c1 - c2 + c3
24524 !c! dECL/dom2
24525        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24526        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24527          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24528        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24529        dGCLdOM2 = c1 - c2 + c3
24530 !c! dECL/dom12
24531        c1 = w1 / (Rhead ** 3.0d0)
24532        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24533        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24534        dGCLdOM12 = c1 - c2 + c3
24535        DO k= 1, 3
24536         erhead(k) = Rhead_distance(k)/Rhead
24537        END DO
24538        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24539        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24540        facd1 = d1i * vbld_inv(i+nres)
24541        facd2 = d1j * vbld_inv(j+nres)
24542        DO k = 1, 3
24543
24544         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24545         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24546                   - dGCLdR * pom
24547         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24548         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24549                   + dGCLdR * pom
24550
24551         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24552                   - dGCLdR * erhead(k)
24553         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24554                   + dGCLdR * erhead(k)
24555        END DO
24556        endif
24557 !now charge with dipole eg. ARG-dG
24558        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24559       alphapol1 = alphapol_scbase(itypi,itypj)
24560        w1        = wqdip_scbase(1,itypi,itypj)
24561        w2        = wqdip_scbase(2,itypi,itypj)
24562 !       w1=0.0d0
24563 !       w2=0.0d0
24564 !       pis       = sig0head_scbase(itypi,itypj)
24565 !       eps_head   = epshead_scbase(itypi,itypj)
24566 !c!-------------------------------------------------------------------
24567 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24568        R1 = 0.0d0
24569        DO k = 1, 3
24570 !c! Calculate head-to-tail distances tail is center of side-chain
24571         R1=R1+(c(k,j+nres)-chead(k,1))**2
24572        END DO
24573 !c! Pitagoras
24574        R1 = dsqrt(R1)
24575
24576 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24577 !c!     &        +dhead(1,1,itypi,itypj))**2))
24578 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24579 !c!     &        +dhead(2,1,itypi,itypj))**2))
24580
24581 !c!-------------------------------------------------------------------
24582 !c! ecl
24583        sparrow  = w1  *  om1
24584        hawk     = w2 *  (1.0d0 - sqom2)
24585        Ecl = sparrow / Rhead**2.0d0 &
24586            - hawk    / Rhead**4.0d0
24587 !c!-------------------------------------------------------------------
24588 !c! derivative of ecl is Gcl
24589 !c! dF/dr part
24590        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24591                 + 4.0d0 * hawk    / Rhead**5.0d0
24592 !c! dF/dom1
24593        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24594 !c! dF/dom2
24595        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24596 !c--------------------------------------------------------------------
24597 !c Polarization energy
24598 !c Epol
24599        MomoFac1 = (1.0d0 - chi1 * sqom2)
24600        RR1  = R1 * R1 / MomoFac1
24601        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24602        fgb1 = sqrt( RR1 + a12sq * ee1)
24603 !       eps_inout_fac=0.0d0
24604        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24605 ! derivative of Epol is Gpol...
24606        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24607                 / (fgb1 ** 5.0d0)
24608        dFGBdR1 = ( (R1 / MomoFac1) &
24609              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24610              / ( 2.0d0 * fgb1 )
24611        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24612                * (2.0d0 - 0.5d0 * ee1) ) &
24613                / (2.0d0 * fgb1)
24614        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24615 !       dPOLdR1 = 0.0d0
24616        dPOLdOM1 = 0.0d0
24617        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24618        DO k = 1, 3
24619         erhead(k) = Rhead_distance(k)/Rhead
24620         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24621        END DO
24622
24623        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24624        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24625        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24626 !       bat=0.0d0
24627        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24628        facd1 = d1i * vbld_inv(i+nres)
24629        facd2 = d1j * vbld_inv(j+nres)
24630 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24631
24632        DO k = 1, 3
24633         hawk = (erhead_tail(k,1) + &
24634         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24635 !        facd1=0.0d0
24636 !        facd2=0.0d0
24637         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24638         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24639                    - dGCLdR * pom &
24640                    - dPOLdR1 *  (erhead_tail(k,1))
24641 !     &             - dGLJdR * pom
24642
24643         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24644         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24645                    + dGCLdR * pom  &
24646                    + dPOLdR1 * (erhead_tail(k,1))
24647 !     &             + dGLJdR * pom
24648
24649
24650         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24651                   - dGCLdR * erhead(k) &
24652                   - dPOLdR1 * erhead_tail(k,1)
24653 !     &             - dGLJdR * erhead(k)
24654
24655         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24656                   + dGCLdR * erhead(k)  &
24657                   + dPOLdR1 * erhead_tail(k,1)
24658 !     &             + dGLJdR * erhead(k)
24659
24660        END DO
24661        endif
24662 !       print *,i,j,evdwij,epol,Fcav,ECL
24663        escbase=escbase+evdwij+epol+Fcav+ECL
24664        call sc_grad_scbase
24665          enddo
24666       enddo
24667
24668       return
24669       end subroutine eprot_sc_base
24670       SUBROUTINE sc_grad_scbase
24671       use calc_data
24672
24673        real (kind=8) :: dcosom1(3),dcosom2(3)
24674        eom1  =    &
24675               eps2der * eps2rt_om1   &
24676             - 2.0D0 * alf1 * eps3der &
24677             + sigder * sigsq_om1     &
24678             + dCAVdOM1               &
24679             + dGCLdOM1               &
24680             + dPOLdOM1
24681
24682        eom2  =  &
24683               eps2der * eps2rt_om2   &
24684             + 2.0D0 * alf2 * eps3der &
24685             + sigder * sigsq_om2     &
24686             + dCAVdOM2               &
24687             + dGCLdOM2               &
24688             + dPOLdOM2
24689
24690        eom12 =    &
24691               evdwij  * eps1_om12     &
24692             + eps2der * eps2rt_om12   &
24693             - 2.0D0 * alf12 * eps3der &
24694             + sigder *sigsq_om12      &
24695             + dCAVdOM12               &
24696             + dGCLdOM12
24697
24698 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24699 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24700 !               gg(1),gg(2),"rozne"
24701        DO k = 1, 3
24702         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24703         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24704         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24705         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24706                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24707                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24708         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24709                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24710                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24711         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24712         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24713        END DO
24714        RETURN
24715       END SUBROUTINE sc_grad_scbase
24716
24717
24718       subroutine epep_sc_base(epepbase)
24719       use calc_data
24720       logical :: lprn
24721 !el local variables
24722       integer :: iint,itypi,itypi1,itypj,subchap
24723       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24724       real(kind=8) :: evdw,sig0ij
24725       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24726                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24727                     sslipi,sslipj,faclip
24728       integer :: ii
24729       real(kind=8) :: fracinbuf
24730        real (kind=8) :: epepbase
24731        real (kind=8),dimension(4):: ener
24732        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24733        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24734         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24735         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24736         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24737         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24738         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24739         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24740        real(kind=8),dimension(3,2)::chead,erhead_tail
24741        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24742        integer troll
24743        eps_out=80.0d0
24744        epepbase=0.0d0
24745 !       do i=1,nres_molec(1)-1
24746         do i=ibond_start,ibond_end
24747         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24748 !C        itypi  = itype(i,1)
24749         dxi    = dc_norm(1,i)
24750         dyi    = dc_norm(2,i)
24751         dzi    = dc_norm(3,i)
24752 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24753         dsci_inv = vbld_inv(i+1)/2.0
24754         xi=(c(1,i)+c(1,i+1))/2.0
24755         yi=(c(2,i)+c(2,i+1))/2.0
24756         zi=(c(3,i)+c(3,i+1))/2.0
24757         xi=mod(xi,boxxsize)
24758          if (xi.lt.0) xi=xi+boxxsize
24759         yi=mod(yi,boxysize)
24760          if (yi.lt.0) yi=yi+boxysize
24761         zi=mod(zi,boxzsize)
24762          if (zi.lt.0) zi=zi+boxzsize
24763          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24764            itypj= itype(j,2)
24765            if (itype(j,2).eq.ntyp1_molec(2))cycle
24766            xj=c(1,j+nres)
24767            yj=c(2,j+nres)
24768            zj=c(3,j+nres)
24769            xj=dmod(xj,boxxsize)
24770            if (xj.lt.0) xj=xj+boxxsize
24771            yj=dmod(yj,boxysize)
24772            if (yj.lt.0) yj=yj+boxysize
24773            zj=dmod(zj,boxzsize)
24774            if (zj.lt.0) zj=zj+boxzsize
24775           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24776           xj_safe=xj
24777           yj_safe=yj
24778           zj_safe=zj
24779           subchap=0
24780
24781           do xshift=-1,1
24782           do yshift=-1,1
24783           do zshift=-1,1
24784           xj=xj_safe+xshift*boxxsize
24785           yj=yj_safe+yshift*boxysize
24786           zj=zj_safe+zshift*boxzsize
24787           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24788           if(dist_temp.lt.dist_init) then
24789             dist_init=dist_temp
24790             xj_temp=xj
24791             yj_temp=yj
24792             zj_temp=zj
24793             subchap=1
24794           endif
24795           enddo
24796           enddo
24797           enddo
24798           if (subchap.eq.1) then
24799           xj=xj_temp-xi
24800           yj=yj_temp-yi
24801           zj=zj_temp-zi
24802           else
24803           xj=xj_safe-xi
24804           yj=yj_safe-yi
24805           zj=zj_safe-zi
24806           endif
24807           dxj = dc_norm( 1, nres+j )
24808           dyj = dc_norm( 2, nres+j )
24809           dzj = dc_norm( 3, nres+j )
24810 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24811 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24812
24813 ! Gay-berne var's
24814           sig0ij = sigma_pepbase(itypj )
24815           chi1   = chi_pepbase(itypj,1 )
24816           chi2   = chi_pepbase(itypj,2 )
24817 !          chi1=0.0d0
24818 !          chi2=0.0d0
24819           chi12  = chi1 * chi2
24820           chip1  = chipp_pepbase(itypj,1 )
24821           chip2  = chipp_pepbase(itypj,2 )
24822 !          chip1=0.0d0
24823 !          chip2=0.0d0
24824           chip12 = chip1 * chip2
24825           chis1 = chis_pepbase(itypj,1)
24826           chis2 = chis_pepbase(itypj,2)
24827           chis12 = chis1 * chis2
24828           sig1 = sigmap1_pepbase(itypj)
24829           sig2 = sigmap2_pepbase(itypj)
24830 !       write (*,*) "sig1 = ", sig1
24831 !       write (*,*) "sig2 = ", sig2
24832        DO k = 1,3
24833 ! location of polar head is computed by taking hydrophobic centre
24834 ! and moving by a d1 * dc_norm vector
24835 ! see unres publications for very informative images
24836         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24837 ! + d1i * dc_norm(k, i+nres)
24838         chead(k,2) = c(k, j+nres)
24839 ! + d1j * dc_norm(k, j+nres)
24840 ! distance
24841 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24842 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24843         Rhead_distance(k) = chead(k,2) - chead(k,1)
24844 !        print *,gvdwc_pepbase(k,i)
24845
24846        END DO
24847        Rhead = dsqrt( &
24848           (Rhead_distance(1)*Rhead_distance(1)) &
24849         + (Rhead_distance(2)*Rhead_distance(2)) &
24850         + (Rhead_distance(3)*Rhead_distance(3)))
24851
24852 ! alpha factors from Fcav/Gcav
24853           b1 = alphasur_pepbase(1,itypj)
24854 !          b1=0.0d0
24855           b2 = alphasur_pepbase(2,itypj)
24856           b3 = alphasur_pepbase(3,itypj)
24857           b4 = alphasur_pepbase(4,itypj)
24858           alf1   = 0.0d0
24859           alf2   = 0.0d0
24860           alf12  = 0.0d0
24861           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24862 !          print *,i,j,rrij
24863           rij  = dsqrt(rrij)
24864 !----------------------------
24865        evdwij = 0.0d0
24866        ECL = 0.0d0
24867        Elj = 0.0d0
24868        Equad = 0.0d0
24869        Epol = 0.0d0
24870        Fcav=0.0d0
24871        eheadtail = 0.0d0
24872        dGCLdOM1 = 0.0d0
24873        dGCLdOM2 = 0.0d0
24874        dGCLdOM12 = 0.0d0
24875        dPOLdOM1 = 0.0d0
24876        dPOLdOM2 = 0.0d0
24877           Fcav = 0.0d0
24878           dFdR = 0.0d0
24879           dCAVdOM1  = 0.0d0
24880           dCAVdOM2  = 0.0d0
24881           dCAVdOM12 = 0.0d0
24882           dscj_inv = vbld_inv(j+nres)
24883           CALL sc_angular
24884 ! this should be in elgrad_init but om's are calculated by sc_angular
24885 ! which in turn is used by older potentials
24886 ! om = omega, sqom = om^2
24887           sqom1  = om1 * om1
24888           sqom2  = om2 * om2
24889           sqom12 = om12 * om12
24890
24891 ! now we calculate EGB - Gey-Berne
24892 ! It will be summed up in evdwij and saved in evdw
24893           sigsq     = 1.0D0  / sigsq
24894           sig       = sig0ij * dsqrt(sigsq)
24895           rij_shift = 1.0/rij - sig + sig0ij
24896           IF (rij_shift.le.0.0D0) THEN
24897            evdw = 1.0D20
24898            RETURN
24899           END IF
24900           sigder = -sig * sigsq
24901           rij_shift = 1.0D0 / rij_shift
24902           fac       = rij_shift**expon
24903           c1        = fac  * fac * aa_pepbase(itypj)
24904 !          c1        = 0.0d0
24905           c2        = fac  * bb_pepbase(itypj)
24906 !          c2        = 0.0d0
24907           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24908           eps2der   = eps3rt * evdwij
24909           eps3der   = eps2rt * evdwij
24910 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24911           evdwij    = eps2rt * eps3rt * evdwij
24912           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24913           fac    = -expon * (c1 + evdwij) * rij_shift
24914           sigder = fac * sigder
24915 !          fac    = rij * fac
24916 ! Calculate distance derivative
24917           gg(1) =  fac
24918           gg(2) =  fac
24919           gg(3) =  fac
24920           fac = chis1 * sqom1 + chis2 * sqom2 &
24921           - 2.0d0 * chis12 * om1 * om2 * om12
24922 ! we will use pom later in Gcav, so dont mess with it!
24923           pom = 1.0d0 - chis1 * chis2 * sqom12
24924           Lambf = (1.0d0 - (fac / pom))
24925           Lambf = dsqrt(Lambf)
24926           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24927 !       write (*,*) "sparrow = ", sparrow
24928           Chif = 1.0d0/rij * sparrow
24929           ChiLambf = Chif * Lambf
24930           eagle = dsqrt(ChiLambf)
24931           bat = ChiLambf ** 11.0d0
24932           top = b1 * ( eagle + b2 * ChiLambf - b3 )
24933           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24934           botsq = bot * bot
24935           Fcav = top / bot
24936 !          print *,i,j,Fcav
24937           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24938           dbot = 12.0d0 * b4 * bat * Lambf
24939           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24940 !       dFdR = 0.0d0
24941 !      write (*,*) "dFcav/dR = ", dFdR
24942           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24943           dbot = 12.0d0 * b4 * bat * Chif
24944           eagle = Lambf * pom
24945           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24946           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24947           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24948               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24949
24950           dFdL = ((dtop * bot - top * dbot) / botsq)
24951 !       dFdL = 0.0d0
24952           dCAVdOM1  = dFdL * ( dFdOM1 )
24953           dCAVdOM2  = dFdL * ( dFdOM2 )
24954           dCAVdOM12 = dFdL * ( dFdOM12 )
24955
24956           ertail(1) = xj*rij
24957           ertail(2) = yj*rij
24958           ertail(3) = zj*rij
24959        DO k = 1, 3
24960 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24961 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24962         pom = ertail(k)
24963 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24964         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24965                   - (( dFdR + gg(k) ) * pom)/2.0
24966 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24967 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24968 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24969 !     &             - ( dFdR * pom )
24970         pom = ertail(k)
24971 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24972         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24973                   + (( dFdR + gg(k) ) * pom)
24974 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24975 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24976 !c!     &             + ( dFdR * pom )
24977
24978         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24979                   - (( dFdR + gg(k) ) * ertail(k))/2.0
24980 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24981
24982 !c!     &             - ( dFdR * ertail(k))
24983
24984         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24985                   + (( dFdR + gg(k) ) * ertail(k))
24986 !c!     &             + ( dFdR * ertail(k))
24987
24988         gg(k) = 0.0d0
24989 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24990 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24991       END DO
24992
24993
24994        w1 = wdipdip_pepbase(1,itypj)
24995        w2 = -wdipdip_pepbase(3,itypj)/2.0
24996        w3 = wdipdip_pepbase(2,itypj)
24997 !       w1=0.0d0
24998 !       w2=0.0d0
24999 !c!-------------------------------------------------------------------
25000 !c! ECL
25001 !       w3=0.0d0
25002        fac = (om12 - 3.0d0 * om1 * om2)
25003        c1 = (w1 / (Rhead**3.0d0)) * fac
25004        c2 = (w2 / Rhead ** 6.0d0)  &
25005          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25006        c3= (w3/ Rhead ** 6.0d0)  &
25007          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25008
25009        ECL = c1 - c2 + c3
25010
25011        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25012        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25013          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25014        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25015          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25016
25017        dGCLdR = c1 - c2 + c3
25018 !c! dECL/dom1
25019        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25020        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25021          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25022        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25023        dGCLdOM1 = c1 - c2 + c3
25024 !c! dECL/dom2
25025        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25026        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25027          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25028        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25029
25030        dGCLdOM2 = c1 - c2 + c3
25031 !c! dECL/dom12
25032        c1 = w1 / (Rhead ** 3.0d0)
25033        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25034        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25035        dGCLdOM12 = c1 - c2 + c3
25036        DO k= 1, 3
25037         erhead(k) = Rhead_distance(k)/Rhead
25038        END DO
25039        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25040        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25041 !       facd1 = d1 * vbld_inv(i+nres)
25042 !       facd2 = d2 * vbld_inv(j+nres)
25043        DO k = 1, 3
25044
25045 !        pom = erhead(k)
25046 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25047 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
25048 !                  - dGCLdR * pom
25049         pom = erhead(k)
25050 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25051         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25052                   + dGCLdR * pom
25053
25054         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25055                   - dGCLdR * erhead(k)/2.0d0
25056 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25057         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25058                   - dGCLdR * erhead(k)/2.0d0
25059 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25060         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25061                   + dGCLdR * erhead(k)
25062        END DO
25063 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
25064        epepbase=epepbase+evdwij+Fcav+ECL
25065        call sc_grad_pepbase
25066        enddo
25067        enddo
25068       END SUBROUTINE epep_sc_base
25069       SUBROUTINE sc_grad_pepbase
25070       use calc_data
25071
25072        real (kind=8) :: dcosom1(3),dcosom2(3)
25073        eom1  =    &
25074               eps2der * eps2rt_om1   &
25075             - 2.0D0 * alf1 * eps3der &
25076             + sigder * sigsq_om1     &
25077             + dCAVdOM1               &
25078             + dGCLdOM1               &
25079             + dPOLdOM1
25080
25081        eom2  =  &
25082               eps2der * eps2rt_om2   &
25083             + 2.0D0 * alf2 * eps3der &
25084             + sigder * sigsq_om2     &
25085             + dCAVdOM2               &
25086             + dGCLdOM2               &
25087             + dPOLdOM2
25088
25089        eom12 =    &
25090               evdwij  * eps1_om12     &
25091             + eps2der * eps2rt_om12   &
25092             - 2.0D0 * alf12 * eps3der &
25093             + sigder *sigsq_om12      &
25094             + dCAVdOM12               &
25095             + dGCLdOM12
25096 !        om12=0.0
25097 !        eom12=0.0
25098 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25099 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
25100 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25101 !                 *dsci_inv*2.0
25102 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25103 !               gg(1),gg(2),"rozne"
25104        DO k = 1, 3
25105         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
25106         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25107         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25108         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
25109                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25110                  *dsci_inv*2.0 &
25111                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25112         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
25113                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
25114                  *dsci_inv*2.0 &
25115                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25116 !         print *,eom12,eom2,om12,om2
25117 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25118 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25119         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
25120                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25121                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25122         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
25123        END DO
25124        RETURN
25125       END SUBROUTINE sc_grad_pepbase
25126       subroutine eprot_sc_phosphate(escpho)
25127       use calc_data
25128 !      implicit real*8 (a-h,o-z)
25129 !      include 'DIMENSIONS'
25130 !      include 'COMMON.GEO'
25131 !      include 'COMMON.VAR'
25132 !      include 'COMMON.LOCAL'
25133 !      include 'COMMON.CHAIN'
25134 !      include 'COMMON.DERIV'
25135 !      include 'COMMON.NAMES'
25136 !      include 'COMMON.INTERACT'
25137 !      include 'COMMON.IOUNITS'
25138 !      include 'COMMON.CALC'
25139 !      include 'COMMON.CONTROL'
25140 !      include 'COMMON.SBRIDGE'
25141       logical :: lprn
25142 !el local variables
25143       integer :: iint,itypi,itypi1,itypj,subchap
25144       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25145       real(kind=8) :: evdw,sig0ij
25146       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25147                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25148                     sslipi,sslipj,faclip,alpha_sco
25149       integer :: ii
25150       real(kind=8) :: fracinbuf
25151        real (kind=8) :: escpho
25152        real (kind=8),dimension(4):: ener
25153        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25154        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25155         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25156         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25157         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25158         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25159         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25160         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25161        real(kind=8),dimension(3,2)::chead,erhead_tail
25162        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25163        integer troll
25164        eps_out=80.0d0
25165        escpho=0.0d0
25166 !       do i=1,nres_molec(1)
25167         do i=ibond_start,ibond_end
25168         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25169         itypi  = itype(i,1)
25170         dxi    = dc_norm(1,nres+i)
25171         dyi    = dc_norm(2,nres+i)
25172         dzi    = dc_norm(3,nres+i)
25173         dsci_inv = vbld_inv(i+nres)
25174         xi=c(1,nres+i)
25175         yi=c(2,nres+i)
25176         zi=c(3,nres+i)
25177         xi=mod(xi,boxxsize)
25178          if (xi.lt.0) xi=xi+boxxsize
25179         yi=mod(yi,boxysize)
25180          if (yi.lt.0) yi=yi+boxysize
25181         zi=mod(zi,boxzsize)
25182          if (zi.lt.0) zi=zi+boxzsize
25183          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25184            itypj= itype(j,2)
25185            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25186             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25187            xj=(c(1,j)+c(1,j+1))/2.0
25188            yj=(c(2,j)+c(2,j+1))/2.0
25189            zj=(c(3,j)+c(3,j+1))/2.0
25190            xj=dmod(xj,boxxsize)
25191            if (xj.lt.0) xj=xj+boxxsize
25192            yj=dmod(yj,boxysize)
25193            if (yj.lt.0) yj=yj+boxysize
25194            zj=dmod(zj,boxzsize)
25195            if (zj.lt.0) zj=zj+boxzsize
25196           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25197           xj_safe=xj
25198           yj_safe=yj
25199           zj_safe=zj
25200           subchap=0
25201           do xshift=-1,1
25202           do yshift=-1,1
25203           do zshift=-1,1
25204           xj=xj_safe+xshift*boxxsize
25205           yj=yj_safe+yshift*boxysize
25206           zj=zj_safe+zshift*boxzsize
25207           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25208           if(dist_temp.lt.dist_init) then
25209             dist_init=dist_temp
25210             xj_temp=xj
25211             yj_temp=yj
25212             zj_temp=zj
25213             subchap=1
25214           endif
25215           enddo
25216           enddo
25217           enddo
25218           if (subchap.eq.1) then
25219           xj=xj_temp-xi
25220           yj=yj_temp-yi
25221           zj=zj_temp-zi
25222           else
25223           xj=xj_safe-xi
25224           yj=yj_safe-yi
25225           zj=zj_safe-zi
25226           endif
25227           dxj = dc_norm( 1,j )
25228           dyj = dc_norm( 2,j )
25229           dzj = dc_norm( 3,j )
25230           dscj_inv = vbld_inv(j+1)
25231
25232 ! Gay-berne var's
25233           sig0ij = sigma_scpho(itypi )
25234           chi1   = chi_scpho(itypi,1 )
25235           chi2   = chi_scpho(itypi,2 )
25236 !          chi1=0.0d0
25237 !          chi2=0.0d0
25238           chi12  = chi1 * chi2
25239           chip1  = chipp_scpho(itypi,1 )
25240           chip2  = chipp_scpho(itypi,2 )
25241 !          chip1=0.0d0
25242 !          chip2=0.0d0
25243           chip12 = chip1 * chip2
25244           chis1 = chis_scpho(itypi,1)
25245           chis2 = chis_scpho(itypi,2)
25246           chis12 = chis1 * chis2
25247           sig1 = sigmap1_scpho(itypi)
25248           sig2 = sigmap2_scpho(itypi)
25249 !       write (*,*) "sig1 = ", sig1
25250 !       write (*,*) "sig1 = ", sig1
25251 !       write (*,*) "sig2 = ", sig2
25252 ! alpha factors from Fcav/Gcav
25253           alf1   = 0.0d0
25254           alf2   = 0.0d0
25255           alf12  = 0.0d0
25256           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
25257
25258           b1 = alphasur_scpho(1,itypi)
25259 !          b1=0.0d0
25260           b2 = alphasur_scpho(2,itypi)
25261           b3 = alphasur_scpho(3,itypi)
25262           b4 = alphasur_scpho(4,itypi)
25263 ! used to determine whether we want to do quadrupole calculations
25264 ! used by Fgb
25265        eps_in = epsintab_scpho(itypi)
25266        if (eps_in.eq.0.0) eps_in=1.0
25267        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25268 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25269 !-------------------------------------------------------------------
25270 ! tail location and distance calculations
25271           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
25272           d1j = 0.0
25273        DO k = 1,3
25274 ! location of polar head is computed by taking hydrophobic centre
25275 ! and moving by a d1 * dc_norm vector
25276 ! see unres publications for very informative images
25277         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25278         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
25279 ! distance
25280 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25281 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25282         Rhead_distance(k) = chead(k,2) - chead(k,1)
25283        END DO
25284 ! pitagoras (root of sum of squares)
25285        Rhead = dsqrt( &
25286           (Rhead_distance(1)*Rhead_distance(1)) &
25287         + (Rhead_distance(2)*Rhead_distance(2)) &
25288         + (Rhead_distance(3)*Rhead_distance(3)))
25289        Rhead_sq=Rhead**2.0
25290 !-------------------------------------------------------------------
25291 ! zero everything that should be zero'ed
25292        evdwij = 0.0d0
25293        ECL = 0.0d0
25294        Elj = 0.0d0
25295        Equad = 0.0d0
25296        Epol = 0.0d0
25297        Fcav=0.0d0
25298        eheadtail = 0.0d0
25299        dGCLdR=0.0d0
25300        dGCLdOM1 = 0.0d0
25301        dGCLdOM2 = 0.0d0
25302        dGCLdOM12 = 0.0d0
25303        dPOLdOM1 = 0.0d0
25304        dPOLdOM2 = 0.0d0
25305           Fcav = 0.0d0
25306           dFdR = 0.0d0
25307           dCAVdOM1  = 0.0d0
25308           dCAVdOM2  = 0.0d0
25309           dCAVdOM12 = 0.0d0
25310           dscj_inv = vbld_inv(j+1)/2.0
25311 !dhead_scbasej(itypi,itypj)
25312 !          print *,i,j,dscj_inv,dsci_inv
25313 ! rij holds 1/(distance of Calpha atoms)
25314           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25315           rij  = dsqrt(rrij)
25316 !----------------------------
25317           CALL sc_angular
25318 ! this should be in elgrad_init but om's are calculated by sc_angular
25319 ! which in turn is used by older potentials
25320 ! om = omega, sqom = om^2
25321           sqom1  = om1 * om1
25322           sqom2  = om2 * om2
25323           sqom12 = om12 * om12
25324
25325 ! now we calculate EGB - Gey-Berne
25326 ! It will be summed up in evdwij and saved in evdw
25327           sigsq     = 1.0D0  / sigsq
25328           sig       = sig0ij * dsqrt(sigsq)
25329 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25330           rij_shift = 1.0/rij - sig + sig0ij
25331           IF (rij_shift.le.0.0D0) THEN
25332            evdw = 1.0D20
25333            RETURN
25334           END IF
25335           sigder = -sig * sigsq
25336           rij_shift = 1.0D0 / rij_shift
25337           fac       = rij_shift**expon
25338           c1        = fac  * fac * aa_scpho(itypi)
25339 !          c1        = 0.0d0
25340           c2        = fac  * bb_scpho(itypi)
25341 !          c2        = 0.0d0
25342           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25343           eps2der   = eps3rt * evdwij
25344           eps3der   = eps2rt * evdwij
25345 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25346           evdwij    = eps2rt * eps3rt * evdwij
25347           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25348           fac    = -expon * (c1 + evdwij) * rij_shift
25349           sigder = fac * sigder
25350 !          fac    = rij * fac
25351 ! Calculate distance derivative
25352           gg(1) =  fac
25353           gg(2) =  fac
25354           gg(3) =  fac
25355           fac = chis1 * sqom1 + chis2 * sqom2 &
25356           - 2.0d0 * chis12 * om1 * om2 * om12
25357 ! we will use pom later in Gcav, so dont mess with it!
25358           pom = 1.0d0 - chis1 * chis2 * sqom12
25359           Lambf = (1.0d0 - (fac / pom))
25360           Lambf = dsqrt(Lambf)
25361           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25362 !       write (*,*) "sparrow = ", sparrow
25363           Chif = 1.0d0/rij * sparrow
25364           ChiLambf = Chif * Lambf
25365           eagle = dsqrt(ChiLambf)
25366           bat = ChiLambf ** 11.0d0
25367           top = b1 * ( eagle + b2 * ChiLambf - b3 )
25368           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25369           botsq = bot * bot
25370           Fcav = top / bot
25371           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25372           dbot = 12.0d0 * b4 * bat * Lambf
25373           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25374 !       dFdR = 0.0d0
25375 !      write (*,*) "dFcav/dR = ", dFdR
25376           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25377           dbot = 12.0d0 * b4 * bat * Chif
25378           eagle = Lambf * pom
25379           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25380           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25381           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25382               * (chis2 * om2 * om12 - om1) / (eagle * pom)
25383
25384           dFdL = ((dtop * bot - top * dbot) / botsq)
25385 !       dFdL = 0.0d0
25386           dCAVdOM1  = dFdL * ( dFdOM1 )
25387           dCAVdOM2  = dFdL * ( dFdOM2 )
25388           dCAVdOM12 = dFdL * ( dFdOM12 )
25389
25390           ertail(1) = xj*rij
25391           ertail(2) = yj*rij
25392           ertail(3) = zj*rij
25393        DO k = 1, 3
25394 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25395 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25396 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
25397
25398         pom = ertail(k)
25399 !        print *,pom,gg(k),dFdR
25400 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25401         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
25402                   - (( dFdR + gg(k) ) * pom)
25403 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25404 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25405 !     &             - ( dFdR * pom )
25406 !        pom = ertail(k)
25407 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25408 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25409 !                  + (( dFdR + gg(k) ) * pom)
25410 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25411 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25412 !c!     &             + ( dFdR * pom )
25413
25414         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25415                   - (( dFdR + gg(k) ) * ertail(k))
25416 !c!     &             - ( dFdR * ertail(k))
25417
25418         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25419                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25420
25421         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25422                   + (( dFdR + gg(k) ) * ertail(k))/2.0
25423
25424 !c!     &             + ( dFdR * ertail(k))
25425
25426         gg(k) = 0.0d0
25427         ENDDO
25428 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25429 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25430 !      alphapol1 = alphapol_scpho(itypi)
25431        if (wqq_scpho(itypi).ne.0.0) then
25432        Qij=wqq_scpho(itypi)/eps_in
25433        alpha_sco=1.d0/alphi_scpho(itypi)
25434 !       Qij=0.0
25435        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25436 !c! derivative of Ecl is Gcl...
25437        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25438                 (Rhead*alpha_sco+1) ) / Rhead_sq
25439        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25440        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25441        w1        = wqdip_scpho(1,itypi)
25442        w2        = wqdip_scpho(2,itypi)
25443 !       w1=0.0d0
25444 !       w2=0.0d0
25445 !       pis       = sig0head_scbase(itypi,itypj)
25446 !       eps_head   = epshead_scbase(itypi,itypj)
25447 !c!-------------------------------------------------------------------
25448
25449 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25450 !c!     &        +dhead(1,1,itypi,itypj))**2))
25451 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25452 !c!     &        +dhead(2,1,itypi,itypj))**2))
25453
25454 !c!-------------------------------------------------------------------
25455 !c! ecl
25456        sparrow  = w1  *  om1
25457        hawk     = w2 *  (1.0d0 - sqom2)
25458        Ecl = sparrow / Rhead**2.0d0 &
25459            - hawk    / Rhead**4.0d0
25460 !c!-------------------------------------------------------------------
25461        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25462            1.0/rij,sparrow
25463
25464 !c! derivative of ecl is Gcl
25465 !c! dF/dr part
25466        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25467                 + 4.0d0 * hawk    / Rhead**5.0d0
25468 !c! dF/dom1
25469        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25470 !c! dF/dom2
25471        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25472        endif
25473
25474 !c--------------------------------------------------------------------
25475 !c Polarization energy
25476 !c Epol
25477        R1 = 0.0d0
25478        DO k = 1, 3
25479 !c! Calculate head-to-tail distances tail is center of side-chain
25480         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25481        END DO
25482 !c! Pitagoras
25483        R1 = dsqrt(R1)
25484
25485       alphapol1 = alphapol_scpho(itypi)
25486 !      alphapol1=0.0
25487        MomoFac1 = (1.0d0 - chi2 * sqom1)
25488        RR1  = R1 * R1 / MomoFac1
25489        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25490 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25491        fgb1 = sqrt( RR1 + a12sq * ee1)
25492 !       eps_inout_fac=0.0d0
25493        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25494 ! derivative of Epol is Gpol...
25495        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25496                 / (fgb1 ** 5.0d0)
25497        dFGBdR1 = ( (R1 / MomoFac1) &
25498              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25499              / ( 2.0d0 * fgb1 )
25500        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25501                * (2.0d0 - 0.5d0 * ee1) ) &
25502                / (2.0d0 * fgb1)
25503        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25504 !       dPOLdR1 = 0.0d0
25505 !       dPOLdOM1 = 0.0d0
25506        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25507                * (2.0d0 - 0.5d0 * ee1) ) &
25508                / (2.0d0 * fgb1)
25509
25510        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25511        dPOLdOM2 = 0.0
25512        DO k = 1, 3
25513         erhead(k) = Rhead_distance(k)/Rhead
25514         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25515        END DO
25516
25517        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25518        erdxj = scalar( erhead(1), dC_norm(1,j) )
25519        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25520 !       bat=0.0d0
25521        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25522        facd1 = d1i * vbld_inv(i+nres)
25523        facd2 = d1j * vbld_inv(j)
25524 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25525
25526        DO k = 1, 3
25527         hawk = (erhead_tail(k,1) + &
25528         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25529 !        facd1=0.0d0
25530 !        facd2=0.0d0
25531 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25532 !                pom,(erhead_tail(k,1))
25533
25534 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25535         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25536         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25537                    - dGCLdR * pom &
25538                    - dPOLdR1 *  (erhead_tail(k,1))
25539 !     &             - dGLJdR * pom
25540
25541         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25542 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25543 !                   + dGCLdR * pom  &
25544 !                   + dPOLdR1 * (erhead_tail(k,1))
25545 !     &             + dGLJdR * pom
25546
25547
25548         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25549                   - dGCLdR * erhead(k) &
25550                   - dPOLdR1 * erhead_tail(k,1)
25551 !     &             - dGLJdR * erhead(k)
25552
25553         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25554                   + (dGCLdR * erhead(k)  &
25555                   + dPOLdR1 * erhead_tail(k,1))/2.0
25556         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25557                   + (dGCLdR * erhead(k)  &
25558                   + dPOLdR1 * erhead_tail(k,1))/2.0
25559
25560 !     &             + dGLJdR * erhead(k)
25561 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25562
25563        END DO
25564 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25565        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25566         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25567        escpho=escpho+evdwij+epol+Fcav+ECL
25568        call sc_grad_scpho
25569          enddo
25570
25571       enddo
25572
25573       return
25574       end subroutine eprot_sc_phosphate
25575       SUBROUTINE sc_grad_scpho
25576       use calc_data
25577
25578        real (kind=8) :: dcosom1(3),dcosom2(3)
25579        eom1  =    &
25580               eps2der * eps2rt_om1   &
25581             - 2.0D0 * alf1 * eps3der &
25582             + sigder * sigsq_om1     &
25583             + dCAVdOM1               &
25584             + dGCLdOM1               &
25585             + dPOLdOM1
25586
25587        eom2  =  &
25588               eps2der * eps2rt_om2   &
25589             + 2.0D0 * alf2 * eps3der &
25590             + sigder * sigsq_om2     &
25591             + dCAVdOM2               &
25592             + dGCLdOM2               &
25593             + dPOLdOM2
25594
25595        eom12 =    &
25596               evdwij  * eps1_om12     &
25597             + eps2der * eps2rt_om12   &
25598             - 2.0D0 * alf12 * eps3der &
25599             + sigder *sigsq_om12      &
25600             + dCAVdOM12               &
25601             + dGCLdOM12
25602 !        om12=0.0
25603 !        eom12=0.0
25604 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25605 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25606 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25607 !                 *dsci_inv*2.0
25608 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25609 !               gg(1),gg(2),"rozne"
25610        DO k = 1, 3
25611         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25612         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25613         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25614         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25615                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25616                  *dscj_inv*2.0 &
25617                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25618         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25619                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25620                  *dscj_inv*2.0 &
25621                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25622         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25623                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25624                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25625
25626 !         print *,eom12,eom2,om12,om2
25627 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25628 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25629 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25630 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25631 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25632         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25633        END DO
25634        RETURN
25635       END SUBROUTINE sc_grad_scpho
25636       subroutine eprot_pep_phosphate(epeppho)
25637       use calc_data
25638 !      implicit real*8 (a-h,o-z)
25639 !      include 'DIMENSIONS'
25640 !      include 'COMMON.GEO'
25641 !      include 'COMMON.VAR'
25642 !      include 'COMMON.LOCAL'
25643 !      include 'COMMON.CHAIN'
25644 !      include 'COMMON.DERIV'
25645 !      include 'COMMON.NAMES'
25646 !      include 'COMMON.INTERACT'
25647 !      include 'COMMON.IOUNITS'
25648 !      include 'COMMON.CALC'
25649 !      include 'COMMON.CONTROL'
25650 !      include 'COMMON.SBRIDGE'
25651       logical :: lprn
25652 !el local variables
25653       integer :: iint,itypi,itypi1,itypj,subchap
25654       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25655       real(kind=8) :: evdw,sig0ij
25656       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25657                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25658                     sslipi,sslipj,faclip
25659       integer :: ii
25660       real(kind=8) :: fracinbuf
25661        real (kind=8) :: epeppho
25662        real (kind=8),dimension(4):: ener
25663        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25664        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25665         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25666         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25667         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25668         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25669         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25670         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25671        real(kind=8),dimension(3,2)::chead,erhead_tail
25672        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25673        integer troll
25674        real (kind=8) :: dcosom1(3),dcosom2(3)
25675        epeppho=0.0d0
25676 !       do i=1,nres_molec(1)
25677         do i=ibond_start,ibond_end
25678         if (itype(i,1).eq.ntyp1_molec(1)) cycle
25679         itypi  = itype(i,1)
25680         dsci_inv = vbld_inv(i+1)/2.0
25681         dxi    = dc_norm(1,i)
25682         dyi    = dc_norm(2,i)
25683         dzi    = dc_norm(3,i)
25684         xi=(c(1,i)+c(1,i+1))/2.0
25685         yi=(c(2,i)+c(2,i+1))/2.0
25686         zi=(c(3,i)+c(3,i+1))/2.0
25687         xi=mod(xi,boxxsize)
25688          if (xi.lt.0) xi=xi+boxxsize
25689         yi=mod(yi,boxysize)
25690          if (yi.lt.0) yi=yi+boxysize
25691         zi=mod(zi,boxzsize)
25692          if (zi.lt.0) zi=zi+boxzsize
25693          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25694            itypj= itype(j,2)
25695            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25696             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25697            xj=(c(1,j)+c(1,j+1))/2.0
25698            yj=(c(2,j)+c(2,j+1))/2.0
25699            zj=(c(3,j)+c(3,j+1))/2.0
25700            xj=dmod(xj,boxxsize)
25701            if (xj.lt.0) xj=xj+boxxsize
25702            yj=dmod(yj,boxysize)
25703            if (yj.lt.0) yj=yj+boxysize
25704            zj=dmod(zj,boxzsize)
25705            if (zj.lt.0) zj=zj+boxzsize
25706           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25707           xj_safe=xj
25708           yj_safe=yj
25709           zj_safe=zj
25710           subchap=0
25711           do xshift=-1,1
25712           do yshift=-1,1
25713           do zshift=-1,1
25714           xj=xj_safe+xshift*boxxsize
25715           yj=yj_safe+yshift*boxysize
25716           zj=zj_safe+zshift*boxzsize
25717           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
25718           if(dist_temp.lt.dist_init) then
25719             dist_init=dist_temp
25720             xj_temp=xj
25721             yj_temp=yj
25722             zj_temp=zj
25723             subchap=1
25724           endif
25725           enddo
25726           enddo
25727           enddo
25728           if (subchap.eq.1) then
25729           xj=xj_temp-xi
25730           yj=yj_temp-yi
25731           zj=zj_temp-zi
25732           else
25733           xj=xj_safe-xi
25734           yj=yj_safe-yi
25735           zj=zj_safe-zi
25736           endif
25737           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25738           rij  = dsqrt(rrij)
25739           dxj = dc_norm( 1,j )
25740           dyj = dc_norm( 2,j )
25741           dzj = dc_norm( 3,j )
25742           dscj_inv = vbld_inv(j+1)/2.0
25743 ! Gay-berne var's
25744           sig0ij = sigma_peppho
25745 !          chi1=0.0d0
25746 !          chi2=0.0d0
25747           chi12  = chi1 * chi2
25748 !          chip1=0.0d0
25749 !          chip2=0.0d0
25750           chip12 = chip1 * chip2
25751 !          chis1 = 0.0d0
25752 !          chis2 = 0.0d0
25753           chis12 = chis1 * chis2
25754           sig1 = sigmap1_peppho
25755           sig2 = sigmap2_peppho
25756 !       write (*,*) "sig1 = ", sig1
25757 !       write (*,*) "sig1 = ", sig1
25758 !       write (*,*) "sig2 = ", sig2
25759 ! alpha factors from Fcav/Gcav
25760           alf1   = 0.0d0
25761           alf2   = 0.0d0
25762           alf12  = 0.0d0
25763           b1 = alphasur_peppho(1)
25764 !          b1=0.0d0
25765           b2 = alphasur_peppho(2)
25766           b3 = alphasur_peppho(3)
25767           b4 = alphasur_peppho(4)
25768           CALL sc_angular
25769        sqom1=om1*om1
25770        evdwij = 0.0d0
25771        ECL = 0.0d0
25772        Elj = 0.0d0
25773        Equad = 0.0d0
25774        Epol = 0.0d0
25775        Fcav=0.0d0
25776        eheadtail = 0.0d0
25777        dGCLdR=0.0d0
25778        dGCLdOM1 = 0.0d0
25779        dGCLdOM2 = 0.0d0
25780        dGCLdOM12 = 0.0d0
25781        dPOLdOM1 = 0.0d0
25782        dPOLdOM2 = 0.0d0
25783           Fcav = 0.0d0
25784           dFdR = 0.0d0
25785           dCAVdOM1  = 0.0d0
25786           dCAVdOM2  = 0.0d0
25787           dCAVdOM12 = 0.0d0
25788           rij_shift = rij
25789           fac       = rij_shift**expon
25790           c1        = fac  * fac * aa_peppho
25791 !          c1        = 0.0d0
25792           c2        = fac  * bb_peppho
25793 !          c2        = 0.0d0
25794           evdwij    =  c1 + c2
25795 ! Now cavity....................
25796        eagle = dsqrt(1.0/rij_shift)
25797        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25798           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25799           botsq = bot * bot
25800           Fcav = top / bot
25801           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25802           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25803           dFdR = ((dtop * bot - top * dbot) / botsq)
25804        w1        = wqdip_peppho(1)
25805        w2        = wqdip_peppho(2)
25806 !       w1=0.0d0
25807 !       w2=0.0d0
25808 !       pis       = sig0head_scbase(itypi,itypj)
25809 !       eps_head   = epshead_scbase(itypi,itypj)
25810 !c!-------------------------------------------------------------------
25811
25812 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25813 !c!     &        +dhead(1,1,itypi,itypj))**2))
25814 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25815 !c!     &        +dhead(2,1,itypi,itypj))**2))
25816
25817 !c!-------------------------------------------------------------------
25818 !c! ecl
25819        sparrow  = w1  *  om1
25820        hawk     = w2 *  (1.0d0 - sqom1)
25821        Ecl = sparrow * rij_shift**2.0d0 &
25822            - hawk    * rij_shift**4.0d0
25823 !c!-------------------------------------------------------------------
25824 !c! derivative of ecl is Gcl
25825 !c! dF/dr part
25826 !       rij_shift=5.0
25827        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25828                 + 4.0d0 * hawk    * rij_shift**5.0d0
25829 !c! dF/dom1
25830        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25831 !c! dF/dom2
25832        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25833        eom1  =    dGCLdOM1+dGCLdOM2
25834        eom2  =    0.0
25835
25836           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25837 !          fac=0.0
25838           gg(1) =  fac*xj*rij
25839           gg(2) =  fac*yj*rij
25840           gg(3) =  fac*zj*rij
25841          do k=1,3
25842          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25843          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25844          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25845          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25846          gg(k)=0.0
25847          enddo
25848
25849       DO k = 1, 3
25850         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25851         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25852         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25853         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25854 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25855         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25856 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25857         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25858                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25859         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25860                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25861         enddo
25862        epeppho=epeppho+evdwij+Fcav+ECL
25863 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25864        enddo
25865        enddo
25866       end subroutine eprot_pep_phosphate
25867 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25868       subroutine emomo(evdw)
25869       use calc_data
25870       use comm_momo
25871 !      implicit real*8 (a-h,o-z)
25872 !      include 'DIMENSIONS'
25873 !      include 'COMMON.GEO'
25874 !      include 'COMMON.VAR'
25875 !      include 'COMMON.LOCAL'
25876 !      include 'COMMON.CHAIN'
25877 !      include 'COMMON.DERIV'
25878 !      include 'COMMON.NAMES'
25879 !      include 'COMMON.INTERACT'
25880 !      include 'COMMON.IOUNITS'
25881 !      include 'COMMON.CALC'
25882 !      include 'COMMON.CONTROL'
25883 !      include 'COMMON.SBRIDGE'
25884       logical :: lprn
25885 !el local variables
25886       integer :: iint,itypi1,subchap,isel
25887       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25888       real(kind=8) :: evdw
25889       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25890                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25891                     sslipi,sslipj,faclip,alpha_sco
25892       integer :: ii
25893       real(kind=8) :: fracinbuf
25894        real (kind=8) :: escpho
25895        real (kind=8),dimension(4):: ener
25896        real(kind=8) :: b1,b2,egb
25897        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25898         Lambf,&
25899         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25900         dFdOM2,dFdL,dFdOM12,&
25901         federmaus,&
25902         d1i,d1j
25903 !       real(kind=8),dimension(3,2)::erhead_tail
25904 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25905        real(kind=8) ::  facd4, adler, Fgb, facd3
25906        integer troll,jj,istate
25907        real (kind=8) :: dcosom1(3),dcosom2(3)
25908        evdw=0.0d0
25909        eps_out=80.0d0
25910        sss_ele_cut=1.0d0
25911 !       print *,"EVDW KURW",evdw,nres
25912       do i=iatsc_s,iatsc_e
25913 !        print *,"I am in EVDW",i
25914         itypi=iabs(itype(i,1))
25915 !        if (i.ne.47) cycle
25916         if (itypi.eq.ntyp1) cycle
25917         itypi1=iabs(itype(i+1,1))
25918         xi=c(1,nres+i)
25919         yi=c(2,nres+i)
25920         zi=c(3,nres+i)
25921           xi=dmod(xi,boxxsize)
25922           if (xi.lt.0) xi=xi+boxxsize
25923           yi=dmod(yi,boxysize)
25924           if (yi.lt.0) yi=yi+boxysize
25925           zi=dmod(zi,boxzsize)
25926           if (zi.lt.0) zi=zi+boxzsize
25927
25928        if ((zi.gt.bordlipbot)  &
25929         .and.(zi.lt.bordliptop)) then
25930 !C the energy transfer exist
25931         if (zi.lt.buflipbot) then
25932 !C what fraction I am in
25933          fracinbuf=1.0d0-  &
25934               ((zi-bordlipbot)/lipbufthick)
25935 !C lipbufthick is thickenes of lipid buffore
25936          sslipi=sscalelip(fracinbuf)
25937          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25938         elseif (zi.gt.bufliptop) then
25939          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25940          sslipi=sscalelip(fracinbuf)
25941          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25942         else
25943          sslipi=1.0d0
25944          ssgradlipi=0.0
25945         endif
25946        else
25947          sslipi=0.0d0
25948          ssgradlipi=0.0
25949        endif
25950 !       print *, sslipi,ssgradlipi
25951         dxi=dc_norm(1,nres+i)
25952         dyi=dc_norm(2,nres+i)
25953         dzi=dc_norm(3,nres+i)
25954 !        dsci_inv=dsc_inv(itypi)
25955         dsci_inv=vbld_inv(i+nres)
25956 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25957 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25958 !
25959 ! Calculate SC interaction energy.
25960 !
25961         do iint=1,nint_gr(i)
25962           do j=istart(i,iint),iend(i,iint)
25963 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25964             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25965               call dyn_ssbond_ene(i,j,evdwij)
25966               evdw=evdw+evdwij
25967               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25968                               'evdw',i,j,evdwij,' ss'
25969 !              if (energy_dec) write (iout,*) &
25970 !                              'evdw',i,j,evdwij,' ss'
25971              do k=j+1,iend(i,iint)
25972 !C search over all next residues
25973               if (dyn_ss_mask(k)) then
25974 !C check if they are cysteins
25975 !C              write(iout,*) 'k=',k
25976
25977 !c              write(iout,*) "PRZED TRI", evdwij
25978 !               evdwij_przed_tri=evdwij
25979               call triple_ssbond_ene(i,j,k,evdwij)
25980 !c               if(evdwij_przed_tri.ne.evdwij) then
25981 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25982 !c               endif
25983
25984 !c              write(iout,*) "PO TRI", evdwij
25985 !C call the energy function that removes the artifical triple disulfide
25986 !C bond the soubroutine is located in ssMD.F
25987               evdw=evdw+evdwij
25988               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25989                             'evdw',i,j,evdwij,'tss'
25990               endif!dyn_ss_mask(k)
25991              enddo! k
25992             ELSE
25993 !el            ind=ind+1
25994             itypj=iabs(itype(j,1))
25995             if (itypj.eq.ntyp1) cycle
25996              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25997
25998 !             if (j.ne.78) cycle
25999 !            dscj_inv=dsc_inv(itypj)
26000             dscj_inv=vbld_inv(j+nres)
26001            xj=c(1,j+nres)
26002            yj=c(2,j+nres)
26003            zj=c(3,j+nres)
26004            xj=dmod(xj,boxxsize)
26005            if (xj.lt.0) xj=xj+boxxsize
26006            yj=dmod(yj,boxysize)
26007            if (yj.lt.0) yj=yj+boxysize
26008            zj=dmod(zj,boxzsize)
26009            if (zj.lt.0) zj=zj+boxzsize
26010           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
26011           xj_safe=xj
26012           yj_safe=yj
26013           zj_safe=zj
26014           subchap=0
26015
26016           do xshift=-1,1
26017           do yshift=-1,1
26018           do zshift=-1,1
26019           xj=xj_safe+xshift*boxxsize
26020           yj=yj_safe+yshift*boxysize
26021           zj=zj_safe+zshift*boxzsize
26022           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
26023           if(dist_temp.lt.dist_init) then
26024             dist_init=dist_temp
26025             xj_temp=xj
26026             yj_temp=yj
26027             zj_temp=zj
26028             subchap=1
26029           endif
26030           enddo
26031           enddo
26032           enddo
26033           if (subchap.eq.1) then
26034           xj=xj_temp-xi
26035           yj=yj_temp-yi
26036           zj=zj_temp-zi
26037           else
26038           xj=xj_safe-xi
26039           yj=yj_safe-yi
26040           zj=zj_safe-zi
26041           endif
26042           dxj = dc_norm( 1, nres+j )
26043           dyj = dc_norm( 2, nres+j )
26044           dzj = dc_norm( 3, nres+j )
26045 !          print *,i,j,itypi,itypj
26046 !          d1i=0.0d0
26047 !          d1j=0.0d0
26048 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26049 ! Gay-berne var's
26050 !1!          sig0ij = sigma_scsc( itypi,itypj )
26051 !          chi1=0.0d0
26052 !          chi2=0.0d0
26053 !          chip1=0.0d0
26054 !          chip2=0.0d0
26055 ! not used by momo potential, but needed by sc_angular which is shared
26056 ! by all energy_potential subroutines
26057           alf1   = 0.0d0
26058           alf2   = 0.0d0
26059           alf12  = 0.0d0
26060           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26061 !       a12sq = a12sq * a12sq
26062 ! charge of amino acid itypi is...
26063           chis1 = chis(itypi,itypj)
26064           chis2 = chis(itypj,itypi)
26065           chis12 = chis1 * chis2
26066           sig1 = sigmap1(itypi,itypj)
26067           sig2 = sigmap2(itypi,itypj)
26068 !       write (*,*) "sig1 = ", sig1
26069 !          chis1=0.0
26070 !          chis2=0.0
26071 !                    chis12 = chis1 * chis2
26072 !          sig1=0.0
26073 !          sig2=0.0
26074 !       write (*,*) "sig2 = ", sig2
26075 ! alpha factors from Fcav/Gcav
26076           b1cav = alphasur(1,itypi,itypj)
26077 !          b1cav=0.0d0
26078           b2cav = alphasur(2,itypi,itypj)
26079           b3cav = alphasur(3,itypi,itypj)
26080           b4cav = alphasur(4,itypi,itypj)
26081 ! used to determine whether we want to do quadrupole calculations
26082        eps_in = epsintab(itypi,itypj)
26083        if (eps_in.eq.0.0) eps_in=1.0
26084
26085        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26086        Rtail = 0.0d0
26087 !       dtail(1,itypi,itypj)=0.0
26088 !       dtail(2,itypi,itypj)=0.0
26089
26090        DO k = 1, 3
26091         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26092         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26093        END DO
26094 !c! tail distances will be themselves usefull elswhere
26095 !c1 (in Gcav, for example)
26096        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26097        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26098        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26099        Rtail = dsqrt( &
26100           (Rtail_distance(1)*Rtail_distance(1)) &
26101         + (Rtail_distance(2)*Rtail_distance(2)) &
26102         + (Rtail_distance(3)*Rtail_distance(3)))
26103
26104 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26105 !-------------------------------------------------------------------
26106 ! tail location and distance calculations
26107        d1 = dhead(1, 1, itypi, itypj)
26108        d2 = dhead(2, 1, itypi, itypj)
26109
26110        DO k = 1,3
26111 ! location of polar head is computed by taking hydrophobic centre
26112 ! and moving by a d1 * dc_norm vector
26113 ! see unres publications for very informative images
26114         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26115         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26116 ! distance
26117 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26118 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26119         Rhead_distance(k) = chead(k,2) - chead(k,1)
26120        END DO
26121 ! pitagoras (root of sum of squares)
26122        Rhead = dsqrt( &
26123           (Rhead_distance(1)*Rhead_distance(1)) &
26124         + (Rhead_distance(2)*Rhead_distance(2)) &
26125         + (Rhead_distance(3)*Rhead_distance(3)))
26126 !-------------------------------------------------------------------
26127 ! zero everything that should be zero'ed
26128        evdwij = 0.0d0
26129        ECL = 0.0d0
26130        Elj = 0.0d0
26131        Equad = 0.0d0
26132        Epol = 0.0d0
26133        Fcav=0.0d0
26134        eheadtail = 0.0d0
26135        dGCLdOM1 = 0.0d0
26136        dGCLdOM2 = 0.0d0
26137        dGCLdOM12 = 0.0d0
26138        dPOLdOM1 = 0.0d0
26139        dPOLdOM2 = 0.0d0
26140           Fcav = 0.0d0
26141           dFdR = 0.0d0
26142           dCAVdOM1  = 0.0d0
26143           dCAVdOM2  = 0.0d0
26144           dCAVdOM12 = 0.0d0
26145           dscj_inv = vbld_inv(j+nres)
26146 !          print *,i,j,dscj_inv,dsci_inv
26147 ! rij holds 1/(distance of Calpha atoms)
26148           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26149           rij  = dsqrt(rrij)
26150 !----------------------------
26151           CALL sc_angular
26152 ! this should be in elgrad_init but om's are calculated by sc_angular
26153 ! which in turn is used by older potentials
26154 ! om = omega, sqom = om^2
26155           sqom1  = om1 * om1
26156           sqom2  = om2 * om2
26157           sqom12 = om12 * om12
26158
26159 ! now we calculate EGB - Gey-Berne
26160 ! It will be summed up in evdwij and saved in evdw
26161           sigsq     = 1.0D0  / sigsq
26162           sig       = sig0ij * dsqrt(sigsq)
26163 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26164           rij_shift = Rtail - sig + sig0ij
26165           IF (rij_shift.le.0.0D0) THEN
26166            evdw = 1.0D20
26167            RETURN
26168           END IF
26169           sigder = -sig * sigsq
26170           rij_shift = 1.0D0 / rij_shift
26171           fac       = rij_shift**expon
26172           c1        = fac  * fac * aa_aq(itypi,itypj)
26173 !          print *,"ADAM",aa_aq(itypi,itypj)
26174
26175 !          c1        = 0.0d0
26176           c2        = fac  * bb_aq(itypi,itypj)
26177 !          c2        = 0.0d0
26178           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26179           eps2der   = eps3rt * evdwij
26180           eps3der   = eps2rt * evdwij
26181 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26182           evdwij    = eps2rt * eps3rt * evdwij
26183 !#ifdef TSCSC
26184 !          IF (bb_aq(itypi,itypj).gt.0) THEN
26185 !           evdw_p = evdw_p + evdwij
26186 !          ELSE
26187 !           evdw_m = evdw_m + evdwij
26188 !          END IF
26189 !#else
26190           evdw = evdw  &
26191               + evdwij
26192 !#endif
26193
26194           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26195           fac    = -expon * (c1 + evdwij) * rij_shift
26196           sigder = fac * sigder
26197 !          fac    = rij * fac
26198 ! Calculate distance derivative
26199           gg(1) =  fac
26200           gg(2) =  fac
26201           gg(3) =  fac
26202 !          if (b2.gt.0.0) then
26203           fac = chis1 * sqom1 + chis2 * sqom2 &
26204           - 2.0d0 * chis12 * om1 * om2 * om12
26205 ! we will use pom later in Gcav, so dont mess with it!
26206           pom = 1.0d0 - chis1 * chis2 * sqom12
26207           Lambf = (1.0d0 - (fac / pom))
26208 !          print *,"fac,pom",fac,pom,Lambf
26209           Lambf = dsqrt(Lambf)
26210           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26211 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
26212 !       write (*,*) "sparrow = ", sparrow
26213           Chif = Rtail * sparrow
26214 !           print *,"rij,sparrow",rij , sparrow
26215           ChiLambf = Chif * Lambf
26216           eagle = dsqrt(ChiLambf)
26217           bat = ChiLambf ** 11.0d0
26218           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
26219           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
26220           botsq = bot * bot
26221 !          print *,top,bot,"bot,top",ChiLambf,Chif
26222           Fcav = top / bot
26223
26224        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
26225        dbot = 12.0d0 * b4cav * bat * Lambf
26226        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26227
26228           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
26229           dbot = 12.0d0 * b4cav * bat * Chif
26230           eagle = Lambf * pom
26231           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26232           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26233           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26234               * (chis2 * om2 * om12 - om1) / (eagle * pom)
26235
26236           dFdL = ((dtop * bot - top * dbot) / botsq)
26237 !       dFdL = 0.0d0
26238           dCAVdOM1  = dFdL * ( dFdOM1 )
26239           dCAVdOM2  = dFdL * ( dFdOM2 )
26240           dCAVdOM12 = dFdL * ( dFdOM12 )
26241
26242        DO k= 1, 3
26243         ertail(k) = Rtail_distance(k)/Rtail
26244        END DO
26245        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
26246        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
26247        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26248        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26249        DO k = 1, 3
26250 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26251 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26252         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26253         gvdwx(k,i) = gvdwx(k,i) &
26254                   - (( dFdR + gg(k) ) * pom)
26255 !c!     &             - ( dFdR * pom )
26256         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26257         gvdwx(k,j) = gvdwx(k,j)   &
26258                   + (( dFdR + gg(k) ) * pom)
26259 !c!     &             + ( dFdR * pom )
26260
26261         gvdwc(k,i) = gvdwc(k,i)  &
26262                   - (( dFdR + gg(k) ) * ertail(k))
26263 !c!     &             - ( dFdR * ertail(k))
26264
26265         gvdwc(k,j) = gvdwc(k,j) &
26266                   + (( dFdR + gg(k) ) * ertail(k))
26267 !c!     &             + ( dFdR * ertail(k))
26268
26269         gg(k) = 0.0d0
26270 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26271 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26272       END DO
26273
26274
26275 !c! Compute head-head and head-tail energies for each state
26276
26277           isel = iabs(Qi) + iabs(Qj)
26278 ! double charge for Phophorylated! itype - 25,27,27
26279 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
26280 !            Qi=Qi*2
26281 !            Qij=Qij*2
26282 !           endif
26283 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
26284 !            Qj=Qj*2
26285 !            Qij=Qij*2
26286 !           endif
26287
26288 !          isel=0
26289           IF (isel.eq.0) THEN
26290 !c! No charges - do nothing
26291            eheadtail = 0.0d0
26292
26293           ELSE IF (isel.eq.4) THEN
26294 !c! Calculate dipole-dipole interactions
26295            CALL edd(ecl)
26296            eheadtail = ECL
26297 !           eheadtail = 0.0d0
26298
26299           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
26300 !c! Charge-nonpolar interactions
26301           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26302             Qi=Qi*2
26303             Qij=Qij*2
26304            endif
26305           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26306             Qj=Qj*2
26307             Qij=Qij*2
26308            endif
26309
26310            CALL eqn(epol)
26311            eheadtail = epol
26312 !           eheadtail = 0.0d0
26313
26314           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
26315 !c! Nonpolar-charge interactions
26316           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26317             Qi=Qi*2
26318             Qij=Qij*2
26319            endif
26320           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26321             Qj=Qj*2
26322             Qij=Qij*2
26323            endif
26324
26325            CALL enq(epol)
26326            eheadtail = epol
26327 !           eheadtail = 0.0d0
26328
26329           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
26330 !c! Charge-dipole interactions
26331           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26332             Qi=Qi*2
26333             Qij=Qij*2
26334            endif
26335           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26336             Qj=Qj*2
26337             Qij=Qij*2
26338            endif
26339
26340            CALL eqd(ecl, elj, epol)
26341            eheadtail = ECL + elj + epol
26342 !           eheadtail = 0.0d0
26343
26344           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
26345 !c! Dipole-charge interactions
26346           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26347             Qi=Qi*2
26348             Qij=Qij*2
26349            endif
26350           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26351             Qj=Qj*2
26352             Qij=Qij*2
26353            endif
26354            CALL edq(ecl, elj, epol)
26355           eheadtail = ECL + elj + epol
26356 !           eheadtail = 0.0d0
26357
26358           ELSE IF ((isel.eq.2.and.   &
26359                iabs(Qi).eq.1).and.  &
26360                nstate(itypi,itypj).eq.1) THEN
26361 !c! Same charge-charge interaction ( +/+ or -/- )
26362           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26363             Qi=Qi*2
26364             Qij=Qij*2
26365            endif
26366           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26367             Qj=Qj*2
26368             Qij=Qij*2
26369            endif
26370
26371            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
26372            eheadtail = ECL + Egb + Epol + Fisocav + Elj
26373 !           eheadtail = 0.0d0
26374
26375           ELSE IF ((isel.eq.2.and.  &
26376                iabs(Qi).eq.1).and. &
26377                nstate(itypi,itypj).ne.1) THEN
26378 !c! Different charge-charge interaction ( +/- or -/+ )
26379           if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26380             Qi=Qi*2
26381             Qij=Qij*2
26382            endif
26383           if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26384             Qj=Qj*2
26385             Qij=Qij*2
26386            endif
26387
26388            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26389           END IF
26390        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
26391       evdw = evdw  + Fcav + eheadtail
26392
26393        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
26394         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
26395         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
26396         Equad,evdwij+Fcav+eheadtail,evdw
26397 !       evdw = evdw  + Fcav  + eheadtail
26398
26399         iF (nstate(itypi,itypj).eq.1) THEN
26400         CALL sc_grad
26401        END IF
26402 !c!-------------------------------------------------------------------
26403 !c! NAPISY KONCOWE
26404          END DO   ! j
26405         END DO    ! iint
26406        END DO     ! i
26407 !c      write (iout,*) "Number of loop steps in EGB:",ind
26408 !c      energy_dec=.false.
26409 !              print *,"EVDW KURW",evdw,nres
26410
26411        RETURN
26412       END SUBROUTINE emomo
26413 !C------------------------------------------------------------------------------------
26414       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26415       use calc_data
26416       use comm_momo
26417        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26418          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26419 !       integer :: k
26420 !c! Epol and Gpol analytical parameters
26421        alphapol1 = alphapol(itypi,itypj)
26422        alphapol2 = alphapol(itypj,itypi)
26423 !c! Fisocav and Gisocav analytical parameters
26424        al1  = alphiso(1,itypi,itypj)
26425        al2  = alphiso(2,itypi,itypj)
26426        al3  = alphiso(3,itypi,itypj)
26427        al4  = alphiso(4,itypi,itypj)
26428        csig = (1.0d0  &
26429            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26430            + sigiso2(itypi,itypj)**2.0d0))
26431 !c!
26432        pis  = sig0head(itypi,itypj)
26433        eps_head = epshead(itypi,itypj)
26434        Rhead_sq = Rhead * Rhead
26435 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26436 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26437        R1 = 0.0d0
26438        R2 = 0.0d0
26439        DO k = 1, 3
26440 !c! Calculate head-to-tail distances needed by Epol
26441         R1=R1+(ctail(k,2)-chead(k,1))**2
26442         R2=R2+(chead(k,2)-ctail(k,1))**2
26443        END DO
26444 !c! Pitagoras
26445        R1 = dsqrt(R1)
26446        R2 = dsqrt(R2)
26447
26448 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26449 !c!     &        +dhead(1,1,itypi,itypj))**2))
26450 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26451 !c!     &        +dhead(2,1,itypi,itypj))**2))
26452
26453 !c!-------------------------------------------------------------------
26454 !c! Coulomb electrostatic interaction
26455        Ecl = (332.0d0 * Qij) / Rhead
26456 !c! derivative of Ecl is Gcl...
26457        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26458        dGCLdOM1 = 0.0d0
26459        dGCLdOM2 = 0.0d0
26460        dGCLdOM12 = 0.0d0
26461        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26462        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26463        debkap=debaykap(itypi,itypj)
26464        Egb = -(332.0d0 * Qij *&
26465         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26466 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26467 !c! Derivative of Egb is Ggb...
26468        dGGBdFGB = -(-332.0d0 * Qij * &
26469        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26470        -(332.0d0 * Qij *&
26471         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26472        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26473        dGGBdR = dGGBdFGB * dFGBdR
26474 !c!-------------------------------------------------------------------
26475 !c! Fisocav - isotropic cavity creation term
26476 !c! or "how much energy it costs to put charged head in water"
26477        pom = Rhead * csig
26478        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26479        bot = (1.0d0 + al4 * pom**12.0d0)
26480        botsq = bot * bot
26481        FisoCav = top / bot
26482 !      write (*,*) "Rhead = ",Rhead
26483 !      write (*,*) "csig = ",csig
26484 !      write (*,*) "pom = ",pom
26485 !      write (*,*) "al1 = ",al1
26486 !      write (*,*) "al2 = ",al2
26487 !      write (*,*) "al3 = ",al3
26488 !      write (*,*) "al4 = ",al4
26489 !        write (*,*) "top = ",top
26490 !        write (*,*) "bot = ",bot
26491 !c! Derivative of Fisocav is GCV...
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!-------------------------------------------------------------------
26496 !c! Epol
26497 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26498        MomoFac1 = (1.0d0 - chi1 * sqom2)
26499        MomoFac2 = (1.0d0 - chi2 * sqom1)
26500        RR1  = ( R1 * R1 ) / MomoFac1
26501        RR2  = ( R2 * R2 ) / MomoFac2
26502        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26503        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26504        fgb1 = sqrt( RR1 + a12sq * ee1 )
26505        fgb2 = sqrt( RR2 + a12sq * ee2 )
26506        epol = 332.0d0 * eps_inout_fac * ( &
26507       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26508 !c!       epol = 0.0d0
26509        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26510                / (fgb1 ** 5.0d0)
26511        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26512                / (fgb2 ** 5.0d0)
26513        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26514              / ( 2.0d0 * fgb1 )
26515        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26516              / ( 2.0d0 * fgb2 )
26517        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26518                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26519        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26520                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26521        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26522 !c!       dPOLdR1 = 0.0d0
26523        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26524 !c!       dPOLdR2 = 0.0d0
26525        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26526 !c!       dPOLdOM1 = 0.0d0
26527        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26528 !c!       dPOLdOM2 = 0.0d0
26529 !c!-------------------------------------------------------------------
26530 !c! Elj
26531 !c! Lennard-Jones 6-12 interaction between heads
26532        pom = (pis / Rhead)**6.0d0
26533        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26534 !c! derivative of Elj is Glj
26535        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26536              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26537 !c!-------------------------------------------------------------------
26538 !c! Return the results
26539 !c! These things do the dRdX derivatives, that is
26540 !c! allow us to change what we see from function that changes with
26541 !c! distance to function that changes with LOCATION (of the interaction
26542 !c! site)
26543        DO k = 1, 3
26544         erhead(k) = Rhead_distance(k)/Rhead
26545         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26546         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26547        END DO
26548
26549        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26550        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26551        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26552        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26553        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26554        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26555        facd1 = d1 * vbld_inv(i+nres)
26556        facd2 = d2 * vbld_inv(j+nres)
26557        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26558        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26559
26560 !c! Now we add appropriate partial derivatives (one in each dimension)
26561        DO k = 1, 3
26562         hawk   = (erhead_tail(k,1) + &
26563         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26564         condor = (erhead_tail(k,2) + &
26565         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26566
26567         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26568         gvdwx(k,i) = gvdwx(k,i) &
26569                   - dGCLdR * pom&
26570                   - dGGBdR * pom&
26571                   - dGCVdR * pom&
26572                   - dPOLdR1 * hawk&
26573                   - dPOLdR2 * (erhead_tail(k,2)&
26574       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26575                   - dGLJdR * pom
26576
26577         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26578         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26579                    + dGGBdR * pom+ dGCVdR * pom&
26580                   + dPOLdR1 * (erhead_tail(k,1)&
26581       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26582                   + dPOLdR2 * condor + dGLJdR * pom
26583
26584         gvdwc(k,i) = gvdwc(k,i)  &
26585                   - dGCLdR * erhead(k)&
26586                   - dGGBdR * erhead(k)&
26587                   - dGCVdR * erhead(k)&
26588                   - dPOLdR1 * erhead_tail(k,1)&
26589                   - dPOLdR2 * erhead_tail(k,2)&
26590                   - dGLJdR * erhead(k)
26591
26592         gvdwc(k,j) = gvdwc(k,j)         &
26593                   + dGCLdR * erhead(k) &
26594                   + dGGBdR * erhead(k) &
26595                   + dGCVdR * erhead(k) &
26596                   + dPOLdR1 * erhead_tail(k,1) &
26597                   + dPOLdR2 * erhead_tail(k,2)&
26598                   + dGLJdR * erhead(k)
26599
26600        END DO
26601        RETURN
26602       END SUBROUTINE eqq
26603
26604       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26605       use calc_data
26606       use comm_momo
26607        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26608          Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26609 !       integer :: k
26610 !c! Epol and Gpol analytical parameters
26611        alphapol1 = alphapolcat(itypi,itypj)
26612        alphapol2 = alphapolcat(itypj,itypi)
26613 !c! Fisocav and Gisocav analytical parameters
26614        al1  = alphisocat(1,itypi,itypj)
26615        al2  = alphisocat(2,itypi,itypj)
26616        al3  = alphisocat(3,itypi,itypj)
26617        al4  = alphisocat(4,itypi,itypj)
26618        csig = (1.0d0  &
26619            / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26620            + sigiso2cat(itypi,itypj)**2.0d0))
26621 !c!
26622        pis  = sig0headcat(itypi,itypj)
26623        eps_head = epsheadcat(itypi,itypj)
26624        Rhead_sq = Rhead * Rhead
26625 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26626 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26627        R1 = 0.0d0
26628        R2 = 0.0d0
26629        DO k = 1, 3
26630 !c! Calculate head-to-tail distances needed by Epol
26631         R1=R1+(ctail(k,2)-chead(k,1))**2
26632         R2=R2+(chead(k,2)-ctail(k,1))**2
26633        END DO
26634 !c! Pitagoras
26635        R1 = dsqrt(R1)
26636        R2 = dsqrt(R2)
26637
26638 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26639 !c!     &        +dhead(1,1,itypi,itypj))**2))
26640 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26641 !c!     &        +dhead(2,1,itypi,itypj))**2))
26642
26643 !c!-------------------------------------------------------------------
26644 !c! Coulomb electrostatic interaction
26645        Ecl = (332.0d0 * Qij) / Rhead
26646 !c! derivative of Ecl is Gcl...
26647        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26648        dGCLdOM1 = 0.0d0
26649        dGCLdOM2 = 0.0d0
26650        dGCLdOM12 = 0.0d0
26651        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26652        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26653        debkap=debaykapcat(itypi,itypj)
26654        Egb = -(332.0d0 * Qij *&
26655         (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26656 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26657 !c! Derivative of Egb is Ggb...
26658        dGGBdFGB = -(-332.0d0 * Qij * &
26659        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26660        -(332.0d0 * Qij *&
26661         (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26662        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26663        dGGBdR = dGGBdFGB * dFGBdR
26664 !c!-------------------------------------------------------------------
26665 !c! Fisocav - isotropic cavity creation term
26666 !c! or "how much energy it costs to put charged head in water"
26667        pom = Rhead * csig
26668        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26669        bot = (1.0d0 + al4 * pom**12.0d0)
26670        botsq = bot * bot
26671        FisoCav = top / bot
26672 !      write (*,*) "Rhead = ",Rhead
26673 !      write (*,*) "csig = ",csig
26674 !      write (*,*) "pom = ",pom
26675 !      write (*,*) "al1 = ",al1
26676 !      write (*,*) "al2 = ",al2
26677 !      write (*,*) "al3 = ",al3
26678 !      write (*,*) "al4 = ",al4
26679 !        write (*,*) "top = ",top
26680 !        write (*,*) "bot = ",bot
26681 !c! Derivative of Fisocav is GCV...
26682        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26683        dbot = 12.0d0 * al4 * pom ** 11.0d0
26684        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26685 !c!-------------------------------------------------------------------
26686 !c! Epol
26687 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26688        MomoFac1 = (1.0d0 - chi1 * sqom2)
26689        MomoFac2 = (1.0d0 - chi2 * sqom1)
26690        RR1  = ( R1 * R1 ) / MomoFac1
26691        RR2  = ( R2 * R2 ) / MomoFac2
26692        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26693        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26694        fgb1 = sqrt( RR1 + a12sq * ee1 )
26695        fgb2 = sqrt( RR2 + a12sq * ee2 )
26696        epol = 332.0d0 * eps_inout_fac * ( &
26697       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26698 !c!       epol = 0.0d0
26699        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26700                / (fgb1 ** 5.0d0)
26701        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26702                / (fgb2 ** 5.0d0)
26703        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26704              / ( 2.0d0 * fgb1 )
26705        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26706              / ( 2.0d0 * fgb2 )
26707        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26708                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26709        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26710                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26711        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26712 !c!       dPOLdR1 = 0.0d0
26713        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26714 !c!       dPOLdR2 = 0.0d0
26715        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26716 !c!       dPOLdOM1 = 0.0d0
26717        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26718 !c!       dPOLdOM2 = 0.0d0
26719 !c!-------------------------------------------------------------------
26720 !c! Elj
26721 !c! Lennard-Jones 6-12 interaction between heads
26722        pom = (pis / Rhead)**6.0d0
26723        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26724 !c! derivative of Elj is Glj
26725        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26726              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26727 !c!-------------------------------------------------------------------
26728 !c! Return the results
26729 !c! These things do the dRdX derivatives, that is
26730 !c! allow us to change what we see from function that changes with
26731 !c! distance to function that changes with LOCATION (of the interaction
26732 !c! site)
26733        DO k = 1, 3
26734         erhead(k) = Rhead_distance(k)/Rhead
26735         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26736         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26737        END DO
26738
26739        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26740        erdxj = scalar( erhead(1), dC_norm(1,j) )
26741        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26742        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26743        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26744        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26745        facd1 = d1 * vbld_inv(i+nres)
26746        facd2 = d2 * vbld_inv(j)
26747        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26748        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26749
26750 !c! Now we add appropriate partial derivatives (one in each dimension)
26751        DO k = 1, 3
26752         hawk   = (erhead_tail(k,1) + &
26753         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26754         condor = (erhead_tail(k,2) + &
26755         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26756
26757         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26758         gradpepcatx(k,i) = gradpepcatx(k,i) &
26759                   - dGCLdR * pom&
26760                   - dGGBdR * pom&
26761                   - dGCVdR * pom&
26762                   - dPOLdR1 * hawk&
26763                   - dPOLdR2 * (erhead_tail(k,2)&
26764       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26765                   - dGLJdR * pom
26766
26767         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26768 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26769 !                   + dGGBdR * pom+ dGCVdR * pom&
26770 !                  + dPOLdR1 * (erhead_tail(k,1)&
26771 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26772 !                  + dPOLdR2 * condor + dGLJdR * pom
26773
26774         gradpepcat(k,i) = gradpepcat(k,i)  &
26775                   - dGCLdR * erhead(k)&
26776                   - dGGBdR * erhead(k)&
26777                   - dGCVdR * erhead(k)&
26778                   - dPOLdR1 * erhead_tail(k,1)&
26779                   - dPOLdR2 * erhead_tail(k,2)&
26780                   - dGLJdR * erhead(k)
26781
26782         gradpepcat(k,j) = gradpepcat(k,j)         &
26783                   + dGCLdR * erhead(k) &
26784                   + dGGBdR * erhead(k) &
26785                   + dGCVdR * erhead(k) &
26786                   + dPOLdR1 * erhead_tail(k,1) &
26787                   + dPOLdR2 * erhead_tail(k,2)&
26788                   + dGLJdR * erhead(k)
26789
26790        END DO
26791        RETURN
26792       END SUBROUTINE eqq_cat
26793 !c!-------------------------------------------------------------------
26794       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26795       use comm_momo
26796       use calc_data
26797
26798        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26799        double precision ener(4)
26800        double precision dcosom1(3),dcosom2(3)
26801 !c! used in Epol derivatives
26802        double precision facd3, facd4
26803        double precision federmaus, adler
26804        integer istate,ii,jj
26805        real (kind=8) :: Fgb
26806 !       print *,"CALLING EQUAD"
26807 !c! Epol and Gpol analytical parameters
26808        alphapol1 = alphapol(itypi,itypj)
26809        alphapol2 = alphapol(itypj,itypi)
26810 !c! Fisocav and Gisocav analytical parameters
26811        al1  = alphiso(1,itypi,itypj)
26812        al2  = alphiso(2,itypi,itypj)
26813        al3  = alphiso(3,itypi,itypj)
26814        al4  = alphiso(4,itypi,itypj)
26815        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26816             + sigiso2(itypi,itypj)**2.0d0))
26817 !c!
26818        w1   = wqdip(1,itypi,itypj)
26819        w2   = wqdip(2,itypi,itypj)
26820        pis  = sig0head(itypi,itypj)
26821        eps_head = epshead(itypi,itypj)
26822 !c! First things first:
26823 !c! We need to do sc_grad's job with GB and Fcav
26824        eom1  = eps2der * eps2rt_om1 &
26825              - 2.0D0 * alf1 * eps3der&
26826              + sigder * sigsq_om1&
26827              + dCAVdOM1
26828        eom2  = eps2der * eps2rt_om2 &
26829              + 2.0D0 * alf2 * eps3der&
26830              + sigder * sigsq_om2&
26831              + dCAVdOM2
26832        eom12 =  evdwij  * eps1_om12 &
26833              + eps2der * eps2rt_om12 &
26834              - 2.0D0 * alf12 * eps3der&
26835              + sigder *sigsq_om12&
26836              + dCAVdOM12
26837 !c! now some magical transformations to project gradient into
26838 !c! three cartesian vectors
26839        DO k = 1, 3
26840         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26841         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26842         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26843 !c! this acts on hydrophobic center of interaction
26844         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26845                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26846                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26847         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26848                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26849                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26850 !c! this acts on Calpha
26851         gvdwc(k,i)=gvdwc(k,i)-gg(k)
26852         gvdwc(k,j)=gvdwc(k,j)+gg(k)
26853        END DO
26854 !c! sc_grad is done, now we will compute
26855        eheadtail = 0.0d0
26856        eom1 = 0.0d0
26857        eom2 = 0.0d0
26858        eom12 = 0.0d0
26859        DO istate = 1, nstate(itypi,itypj)
26860 !c*************************************************************
26861         IF (istate.ne.1) THEN
26862          IF (istate.lt.3) THEN
26863           ii = 1
26864          ELSE
26865           ii = 2
26866          END IF
26867         jj = istate/ii
26868         d1 = dhead(1,ii,itypi,itypj)
26869         d2 = dhead(2,jj,itypi,itypj)
26870         DO k = 1,3
26871          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26872          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26873          Rhead_distance(k) = chead(k,2) - chead(k,1)
26874         END DO
26875 !c! pitagoras (root of sum of squares)
26876         Rhead = dsqrt( &
26877                (Rhead_distance(1)*Rhead_distance(1))  &
26878              + (Rhead_distance(2)*Rhead_distance(2))  &
26879              + (Rhead_distance(3)*Rhead_distance(3)))
26880         END IF
26881         Rhead_sq = Rhead * Rhead
26882
26883 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26884 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26885         R1 = 0.0d0
26886         R2 = 0.0d0
26887         DO k = 1, 3
26888 !c! Calculate head-to-tail distances
26889          R1=R1+(ctail(k,2)-chead(k,1))**2
26890          R2=R2+(chead(k,2)-ctail(k,1))**2
26891         END DO
26892 !c! Pitagoras
26893         R1 = dsqrt(R1)
26894         R2 = dsqrt(R2)
26895         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26896 !c!        Ecl = 0.0d0
26897 !c!        write (*,*) "Ecl = ", Ecl
26898 !c! derivative of Ecl is Gcl...
26899         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26900 !c!        dGCLdR = 0.0d0
26901         dGCLdOM1 = 0.0d0
26902         dGCLdOM2 = 0.0d0
26903         dGCLdOM12 = 0.0d0
26904 !c!-------------------------------------------------------------------
26905 !c! Generalised Born Solvent Polarization
26906         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26907         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26908         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26909 !c!        Egb = 0.0d0
26910 !c!      write (*,*) "a1*a2 = ", a12sq
26911 !c!      write (*,*) "Rhead = ", Rhead
26912 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26913 !c!      write (*,*) "ee = ", ee
26914 !c!      write (*,*) "Fgb = ", Fgb
26915 !c!      write (*,*) "fac = ", eps_inout_fac
26916 !c!      write (*,*) "Qij = ", Qij
26917 !c!      write (*,*) "Egb = ", Egb
26918 !c! Derivative of Egb is Ggb...
26919 !c! dFGBdR is used by Quad's later...
26920         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26921         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26922                / ( 2.0d0 * Fgb )
26923         dGGBdR = dGGBdFGB * dFGBdR
26924 !c!        dGGBdR = 0.0d0
26925 !c!-------------------------------------------------------------------
26926 !c! Fisocav - isotropic cavity creation term
26927         pom = Rhead * csig
26928         top = al1 * (dsqrt(pom) + al2 * pom - al3)
26929         bot = (1.0d0 + al4 * pom**12.0d0)
26930         botsq = bot * bot
26931         FisoCav = top / bot
26932         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26933         dbot = 12.0d0 * al4 * pom ** 11.0d0
26934         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26935 !c!        dGCVdR = 0.0d0
26936 !c!-------------------------------------------------------------------
26937 !c! Polarization energy
26938 !c! Epol
26939         MomoFac1 = (1.0d0 - chi1 * sqom2)
26940         MomoFac2 = (1.0d0 - chi2 * sqom1)
26941         RR1  = ( R1 * R1 ) / MomoFac1
26942         RR2  = ( R2 * R2 ) / MomoFac2
26943         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26944         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26945         fgb1 = sqrt( RR1 + a12sq * ee1 )
26946         fgb2 = sqrt( RR2 + a12sq * ee2 )
26947         epol = 332.0d0 * eps_inout_fac * (&
26948         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26949 !c!        epol = 0.0d0
26950 !c! derivative of Epol is Gpol...
26951         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26952                   / (fgb1 ** 5.0d0)
26953         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26954                   / (fgb2 ** 5.0d0)
26955         dFGBdR1 = ( (R1 / MomoFac1) &
26956                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
26957                 / ( 2.0d0 * fgb1 )
26958         dFGBdR2 = ( (R2 / MomoFac2) &
26959                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26960                 / ( 2.0d0 * fgb2 )
26961         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26962                  * ( 2.0d0 - 0.5d0 * ee1) ) &
26963                  / ( 2.0d0 * fgb1 )
26964         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26965                  * ( 2.0d0 - 0.5d0 * ee2) ) &
26966                  / ( 2.0d0 * fgb2 )
26967         dPOLdR1 = dPOLdFGB1 * dFGBdR1
26968 !c!        dPOLdR1 = 0.0d0
26969         dPOLdR2 = dPOLdFGB2 * dFGBdR2
26970 !c!        dPOLdR2 = 0.0d0
26971         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26972 !c!        dPOLdOM1 = 0.0d0
26973         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26974         pom = (pis / Rhead)**6.0d0
26975         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26976 !c!        Elj = 0.0d0
26977 !c! derivative of Elj is Glj
26978         dGLJdR = 4.0d0 * eps_head &
26979             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26980             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26981 !c!        dGLJdR = 0.0d0
26982 !c!-------------------------------------------------------------------
26983 !c! Equad
26984        IF (Wqd.ne.0.0d0) THEN
26985         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26986              - 37.5d0  * ( sqom1 + sqom2 ) &
26987              + 157.5d0 * ( sqom1 * sqom2 ) &
26988              - 45.0d0  * om1*om2*om12
26989         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26990         Equad = fac * Beta1
26991 !c!        Equad = 0.0d0
26992 !c! derivative of Equad...
26993         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26994 !c!        dQUADdR = 0.0d0
26995         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26996 !c!        dQUADdOM1 = 0.0d0
26997         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26998 !c!        dQUADdOM2 = 0.0d0
26999         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
27000        ELSE
27001          Beta1 = 0.0d0
27002          Equad = 0.0d0
27003         END IF
27004 !c!-------------------------------------------------------------------
27005 !c! Return the results
27006 !c! Angular stuff
27007         eom1 = dPOLdOM1 + dQUADdOM1
27008         eom2 = dPOLdOM2 + dQUADdOM2
27009         eom12 = dQUADdOM12
27010 !c! now some magical transformations to project gradient into
27011 !c! three cartesian vectors
27012         DO k = 1, 3
27013          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27014          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27015          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
27016         END DO
27017 !c! Radial stuff
27018         DO k = 1, 3
27019          erhead(k) = Rhead_distance(k)/Rhead
27020          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27021          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27022         END DO
27023         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27024         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27025         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27026         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27027         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27028         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27029         facd1 = d1 * vbld_inv(i+nres)
27030         facd2 = d2 * vbld_inv(j+nres)
27031         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27032         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27033         DO k = 1, 3
27034          hawk   = erhead_tail(k,1) + &
27035          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
27036          condor = erhead_tail(k,2) + &
27037          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
27038
27039          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27040 !c! this acts on hydrophobic center of interaction
27041          gheadtail(k,1,1) = gheadtail(k,1,1) &
27042                          - dGCLdR * pom &
27043                          - dGGBdR * pom &
27044                          - dGCVdR * pom &
27045                          - dPOLdR1 * hawk &
27046                          - dPOLdR2 * (erhead_tail(k,2) &
27047       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27048                          - dGLJdR * pom &
27049                          - dQUADdR * pom&
27050                          - tuna(k) &
27051                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27052                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27053
27054          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27055 !c! this acts on hydrophobic center of interaction
27056          gheadtail(k,2,1) = gheadtail(k,2,1)  &
27057                          + dGCLdR * pom      &
27058                          + dGGBdR * pom      &
27059                          + dGCVdR * pom      &
27060                          + dPOLdR1 * (erhead_tail(k,1) &
27061       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27062                          + dPOLdR2 * condor &
27063                          + dGLJdR * pom &
27064                          + dQUADdR * pom &
27065                          + tuna(k) &
27066                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
27067                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27068
27069 !c! this acts on Calpha
27070          gheadtail(k,3,1) = gheadtail(k,3,1)  &
27071                          - dGCLdR * erhead(k)&
27072                          - dGGBdR * erhead(k)&
27073                          - dGCVdR * erhead(k)&
27074                          - dPOLdR1 * erhead_tail(k,1)&
27075                          - dPOLdR2 * erhead_tail(k,2)&
27076                          - dGLJdR * erhead(k) &
27077                          - dQUADdR * erhead(k)&
27078                          - tuna(k)
27079 !c! this acts on Calpha
27080          gheadtail(k,4,1) = gheadtail(k,4,1)   &
27081                           + dGCLdR * erhead(k) &
27082                           + dGGBdR * erhead(k) &
27083                           + dGCVdR * erhead(k) &
27084                           + dPOLdR1 * erhead_tail(k,1) &
27085                           + dPOLdR2 * erhead_tail(k,2) &
27086                           + dGLJdR * erhead(k) &
27087                           + dQUADdR * erhead(k)&
27088                           + tuna(k)
27089         END DO
27090         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
27091         eheadtail = eheadtail &
27092                   + wstate(istate, itypi, itypj) &
27093                   * dexp(-betaT * ener(istate))
27094 !c! foreach cartesian dimension
27095         DO k = 1, 3
27096 !c! foreach of two gvdwx and gvdwc
27097          DO l = 1, 4
27098           gheadtail(k,l,2) = gheadtail(k,l,2)  &
27099                            + wstate( istate, itypi, itypj ) &
27100                            * dexp(-betaT * ener(istate)) &
27101                            * gheadtail(k,l,1)
27102           gheadtail(k,l,1) = 0.0d0
27103          END DO
27104         END DO
27105        END DO
27106 !c! Here ended the gigantic DO istate = 1, 4, which starts
27107 !c! at the beggining of the subroutine
27108
27109        DO k = 1, 3
27110         DO l = 1, 4
27111          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
27112         END DO
27113         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
27114         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
27115         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
27116         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
27117         DO l = 1, 4
27118          gheadtail(k,l,1) = 0.0d0
27119          gheadtail(k,l,2) = 0.0d0
27120         END DO
27121        END DO
27122        eheadtail = (-dlog(eheadtail)) / betaT
27123        dPOLdOM1 = 0.0d0
27124        dPOLdOM2 = 0.0d0
27125        dQUADdOM1 = 0.0d0
27126        dQUADdOM2 = 0.0d0
27127        dQUADdOM12 = 0.0d0
27128        RETURN
27129       END SUBROUTINE energy_quad
27130 !!-----------------------------------------------------------
27131       SUBROUTINE eqn(Epol)
27132       use comm_momo
27133       use calc_data
27134
27135       double precision  facd4, federmaus,epol
27136       alphapol1 = alphapol(itypi,itypj)
27137 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27138        R1 = 0.0d0
27139        DO k = 1, 3
27140 !c! Calculate head-to-tail distances
27141         R1=R1+(ctail(k,2)-chead(k,1))**2
27142        END DO
27143 !c! Pitagoras
27144        R1 = dsqrt(R1)
27145
27146 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27147 !c!     &        +dhead(1,1,itypi,itypj))**2))
27148 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27149 !c!     &        +dhead(2,1,itypi,itypj))**2))
27150 !c--------------------------------------------------------------------
27151 !c Polarization energy
27152 !c Epol
27153        MomoFac1 = (1.0d0 - chi1 * sqom2)
27154        RR1  = R1 * R1 / MomoFac1
27155        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27156        fgb1 = sqrt( RR1 + a12sq * ee1)
27157        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27158        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27159                / (fgb1 ** 5.0d0)
27160        dFGBdR1 = ( (R1 / MomoFac1) &
27161               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27162               / ( 2.0d0 * fgb1 )
27163        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27164                 * (2.0d0 - 0.5d0 * ee1) ) &
27165                 / (2.0d0 * fgb1)
27166        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27167 !c!       dPOLdR1 = 0.0d0
27168        dPOLdOM1 = 0.0d0
27169        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27170        DO k = 1, 3
27171         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27172        END DO
27173        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27174        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27175        facd1 = d1 * vbld_inv(i+nres)
27176        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27177
27178        DO k = 1, 3
27179         hawk = (erhead_tail(k,1) + &
27180         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27181
27182         gvdwx(k,i) = gvdwx(k,i) &
27183                    - dPOLdR1 * hawk
27184         gvdwx(k,j) = gvdwx(k,j) &
27185                    + dPOLdR1 * (erhead_tail(k,1) &
27186        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
27187
27188         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
27189         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
27190
27191        END DO
27192        RETURN
27193       END SUBROUTINE eqn
27194       SUBROUTINE enq(Epol)
27195       use calc_data
27196       use comm_momo
27197        double precision facd3, adler,epol
27198        alphapol2 = alphapol(itypj,itypi)
27199 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27200        R2 = 0.0d0
27201        DO k = 1, 3
27202 !c! Calculate head-to-tail distances
27203         R2=R2+(chead(k,2)-ctail(k,1))**2
27204        END DO
27205 !c! Pitagoras
27206        R2 = dsqrt(R2)
27207
27208 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27209 !c!     &        +dhead(1,1,itypi,itypj))**2))
27210 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27211 !c!     &        +dhead(2,1,itypi,itypj))**2))
27212 !c------------------------------------------------------------------------
27213 !c Polarization energy
27214        MomoFac2 = (1.0d0 - chi2 * sqom1)
27215        RR2  = R2 * R2 / MomoFac2
27216        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27217        fgb2 = sqrt(RR2  + a12sq * ee2)
27218        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27219        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27220                 / (fgb2 ** 5.0d0)
27221        dFGBdR2 = ( (R2 / MomoFac2)  &
27222               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27223               / (2.0d0 * fgb2)
27224        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27225                 * (2.0d0 - 0.5d0 * ee2) ) &
27226                 / (2.0d0 * fgb2)
27227        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27228 !c!       dPOLdR2 = 0.0d0
27229        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27230 !c!       dPOLdOM1 = 0.0d0
27231        dPOLdOM2 = 0.0d0
27232 !c!-------------------------------------------------------------------
27233 !c! Return the results
27234 !c! (See comments in Eqq)
27235        DO k = 1, 3
27236         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27237        END DO
27238        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27239        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27240        facd2 = d2 * vbld_inv(j+nres)
27241        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27242        DO k = 1, 3
27243         condor = (erhead_tail(k,2) &
27244        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27245
27246         gvdwx(k,i) = gvdwx(k,i) &
27247                    - dPOLdR2 * (erhead_tail(k,2) &
27248        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27249         gvdwx(k,j) = gvdwx(k,j)   &
27250                    + dPOLdR2 * condor
27251
27252         gvdwc(k,i) = gvdwc(k,i) &
27253                    - dPOLdR2 * erhead_tail(k,2)
27254         gvdwc(k,j) = gvdwc(k,j) &
27255                    + dPOLdR2 * erhead_tail(k,2)
27256
27257        END DO
27258       RETURN
27259       END SUBROUTINE enq
27260
27261       SUBROUTINE enq_cat(Epol)
27262       use calc_data
27263       use comm_momo
27264        double precision facd3, adler,epol
27265        alphapol2 = alphapolcat(itypj,itypi)
27266 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27267        R2 = 0.0d0
27268        DO k = 1, 3
27269 !c! Calculate head-to-tail distances
27270         R2=R2+(chead(k,2)-ctail(k,1))**2
27271        END DO
27272 !c! Pitagoras
27273        R2 = dsqrt(R2)
27274
27275 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27276 !c!     &        +dhead(1,1,itypi,itypj))**2))
27277 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27278 !c!     &        +dhead(2,1,itypi,itypj))**2))
27279 !c------------------------------------------------------------------------
27280 !c Polarization energy
27281        MomoFac2 = (1.0d0 - chi2 * sqom1)
27282        RR2  = R2 * R2 / MomoFac2
27283        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27284        fgb2 = sqrt(RR2  + a12sq * ee2)
27285        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27286        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27287                 / (fgb2 ** 5.0d0)
27288        dFGBdR2 = ( (R2 / MomoFac2)  &
27289               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27290               / (2.0d0 * fgb2)
27291        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27292                 * (2.0d0 - 0.5d0 * ee2) ) &
27293                 / (2.0d0 * fgb2)
27294        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27295 !c!       dPOLdR2 = 0.0d0
27296        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27297 !c!       dPOLdOM1 = 0.0d0
27298        dPOLdOM2 = 0.0d0
27299
27300 !c!-------------------------------------------------------------------
27301 !c! Return the results
27302 !c! (See comments in Eqq)
27303        DO k = 1, 3
27304         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27305        END DO
27306        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27307        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27308        facd2 = d2 * vbld_inv(j+nres)
27309        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27310        DO k = 1, 3
27311         condor = (erhead_tail(k,2) &
27312        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27313
27314         gradpepcatx(k,i) = gradpepcatx(k,i) &
27315                    - dPOLdR2 * (erhead_tail(k,2) &
27316        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27317 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
27318 !                   + dPOLdR2 * condor
27319
27320         gradpepcat(k,i) = gradpepcat(k,i) &
27321                    - dPOLdR2 * erhead_tail(k,2)
27322         gradpepcat(k,j) = gradpepcat(k,j) &
27323                    + dPOLdR2 * erhead_tail(k,2)
27324
27325        END DO
27326       RETURN
27327       END SUBROUTINE enq_cat
27328
27329       SUBROUTINE eqd(Ecl,Elj,Epol)
27330       use calc_data
27331       use comm_momo
27332        double precision  facd4, federmaus,ecl,elj,epol
27333        alphapol1 = alphapol(itypi,itypj)
27334        w1        = wqdip(1,itypi,itypj)
27335        w2        = wqdip(2,itypi,itypj)
27336        pis       = sig0head(itypi,itypj)
27337        eps_head   = epshead(itypi,itypj)
27338 !c!-------------------------------------------------------------------
27339 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27340        R1 = 0.0d0
27341        DO k = 1, 3
27342 !c! Calculate head-to-tail distances
27343         R1=R1+(ctail(k,2)-chead(k,1))**2
27344        END DO
27345 !c! Pitagoras
27346        R1 = dsqrt(R1)
27347
27348 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27349 !c!     &        +dhead(1,1,itypi,itypj))**2))
27350 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27351 !c!     &        +dhead(2,1,itypi,itypj))**2))
27352
27353 !c!-------------------------------------------------------------------
27354 !c! ecl
27355        sparrow  = w1 * Qi * om1
27356        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27357        Ecl = sparrow / Rhead**2.0d0 &
27358            - hawk    / Rhead**4.0d0
27359        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27360                  + 4.0d0 * hawk    / Rhead**5.0d0
27361 !c! dF/dom1
27362        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27363 !c! dF/dom2
27364        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27365 !c--------------------------------------------------------------------
27366 !c Polarization energy
27367 !c Epol
27368        MomoFac1 = (1.0d0 - chi1 * sqom2)
27369        RR1  = R1 * R1 / MomoFac1
27370        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27371        fgb1 = sqrt( RR1 + a12sq * ee1)
27372        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27373 !c!       epol = 0.0d0
27374 !c!------------------------------------------------------------------
27375 !c! derivative of Epol is Gpol...
27376        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27377                / (fgb1 ** 5.0d0)
27378        dFGBdR1 = ( (R1 / MomoFac1)  &
27379              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27380              / ( 2.0d0 * fgb1 )
27381        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27382                * (2.0d0 - 0.5d0 * ee1) ) &
27383                / (2.0d0 * fgb1)
27384        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27385 !c!       dPOLdR1 = 0.0d0
27386        dPOLdOM1 = 0.0d0
27387        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27388 !c!       dPOLdOM2 = 0.0d0
27389 !c!-------------------------------------------------------------------
27390 !c! Elj
27391        pom = (pis / Rhead)**6.0d0
27392        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27393 !c! derivative of Elj is Glj
27394        dGLJdR = 4.0d0 * eps_head &
27395           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27396           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27397        DO k = 1, 3
27398         erhead(k) = Rhead_distance(k)/Rhead
27399         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27400        END DO
27401
27402        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27403        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27404        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27405        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27406        facd1 = d1 * vbld_inv(i+nres)
27407        facd2 = d2 * vbld_inv(j+nres)
27408        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27409
27410        DO k = 1, 3
27411         hawk = (erhead_tail(k,1) +  &
27412         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27413
27414         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27415         gvdwx(k,i) = gvdwx(k,i)  &
27416                    - dGCLdR * pom&
27417                    - dPOLdR1 * hawk &
27418                    - dGLJdR * pom
27419
27420         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27421         gvdwx(k,j) = gvdwx(k,j)    &
27422                    + dGCLdR * pom  &
27423                    + dPOLdR1 * (erhead_tail(k,1) &
27424        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27425                    + dGLJdR * pom
27426
27427
27428         gvdwc(k,i) = gvdwc(k,i)          &
27429                    - dGCLdR * erhead(k)  &
27430                    - dPOLdR1 * erhead_tail(k,1) &
27431                    - dGLJdR * erhead(k)
27432
27433         gvdwc(k,j) = gvdwc(k,j)          &
27434                    + dGCLdR * erhead(k)  &
27435                    + dPOLdR1 * erhead_tail(k,1) &
27436                    + dGLJdR * erhead(k)
27437
27438        END DO
27439        RETURN
27440       END SUBROUTINE eqd
27441       SUBROUTINE edq(Ecl,Elj,Epol)
27442 !       IMPLICIT NONE
27443        use comm_momo
27444       use calc_data
27445
27446       double precision  facd3, adler,ecl,elj,epol
27447        alphapol2 = alphapol(itypj,itypi)
27448        w1        = wqdip(1,itypi,itypj)
27449        w2        = wqdip(2,itypi,itypj)
27450        pis       = sig0head(itypi,itypj)
27451        eps_head  = epshead(itypi,itypj)
27452 !c!-------------------------------------------------------------------
27453 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27454        R2 = 0.0d0
27455        DO k = 1, 3
27456 !c! Calculate head-to-tail distances
27457         R2=R2+(chead(k,2)-ctail(k,1))**2
27458        END DO
27459 !c! Pitagoras
27460        R2 = dsqrt(R2)
27461
27462 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27463 !c!     &        +dhead(1,1,itypi,itypj))**2))
27464 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27465 !c!     &        +dhead(2,1,itypi,itypj))**2))
27466
27467
27468 !c!-------------------------------------------------------------------
27469 !c! ecl
27470        sparrow  = w1 * Qj * om1
27471        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27472        ECL = sparrow / Rhead**2.0d0 &
27473            - hawk    / Rhead**4.0d0
27474 !c!-------------------------------------------------------------------
27475 !c! derivative of ecl is Gcl
27476 !c! dF/dr part
27477        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27478                  + 4.0d0 * hawk    / Rhead**5.0d0
27479 !c! dF/dom1
27480        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27481 !c! dF/dom2
27482        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27483 !c--------------------------------------------------------------------
27484 !c Polarization energy
27485 !c Epol
27486        MomoFac2 = (1.0d0 - chi2 * sqom1)
27487        RR2  = R2 * R2 / MomoFac2
27488        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27489        fgb2 = sqrt(RR2  + a12sq * ee2)
27490        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27491        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27492                / (fgb2 ** 5.0d0)
27493        dFGBdR2 = ( (R2 / MomoFac2)  &
27494                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27495                / (2.0d0 * fgb2)
27496        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27497                 * (2.0d0 - 0.5d0 * ee2) ) &
27498                 / (2.0d0 * fgb2)
27499        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27500 !c!       dPOLdR2 = 0.0d0
27501        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27502 !c!       dPOLdOM1 = 0.0d0
27503        dPOLdOM2 = 0.0d0
27504 !c!-------------------------------------------------------------------
27505 !c! Elj
27506        pom = (pis / Rhead)**6.0d0
27507        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27508 !c! derivative of Elj is Glj
27509        dGLJdR = 4.0d0 * eps_head &
27510            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27511            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27512 !c!-------------------------------------------------------------------
27513 !c! Return the results
27514 !c! (see comments in Eqq)
27515        DO k = 1, 3
27516         erhead(k) = Rhead_distance(k)/Rhead
27517         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27518        END DO
27519        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27520        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27521        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27522        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27523        facd1 = d1 * vbld_inv(i+nres)
27524        facd2 = d2 * vbld_inv(j+nres)
27525        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27526        DO k = 1, 3
27527         condor = (erhead_tail(k,2) &
27528        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27529
27530         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27531         gvdwx(k,i) = gvdwx(k,i) &
27532                   - dGCLdR * pom &
27533                   - dPOLdR2 * (erhead_tail(k,2) &
27534        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27535                   - dGLJdR * pom
27536
27537         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27538         gvdwx(k,j) = gvdwx(k,j) &
27539                   + dGCLdR * pom &
27540                   + dPOLdR2 * condor &
27541                   + dGLJdR * pom
27542
27543
27544         gvdwc(k,i) = gvdwc(k,i) &
27545                   - dGCLdR * erhead(k) &
27546                   - dPOLdR2 * erhead_tail(k,2) &
27547                   - dGLJdR * erhead(k)
27548
27549         gvdwc(k,j) = gvdwc(k,j) &
27550                   + dGCLdR * erhead(k) &
27551                   + dPOLdR2 * erhead_tail(k,2) &
27552                   + dGLJdR * erhead(k)
27553
27554        END DO
27555        RETURN
27556       END SUBROUTINE edq
27557
27558       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27559       use comm_momo
27560       use calc_data
27561
27562       double precision  facd3, adler,ecl,elj,epol
27563        alphapol2 = alphapolcat(itypj,itypi)
27564        w1        = wqdipcat(1,itypi,itypj)
27565        w2        = wqdipcat(2,itypi,itypj)
27566        pis       = sig0headcat(itypi,itypj)
27567        eps_head  = epsheadcat(itypi,itypj)
27568 !c!-------------------------------------------------------------------
27569 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27570        R2 = 0.0d0
27571        DO k = 1, 3
27572 !c! Calculate head-to-tail distances
27573         R2=R2+(chead(k,2)-ctail(k,1))**2
27574        END DO
27575 !c! Pitagoras
27576        R2 = dsqrt(R2)
27577
27578 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27579 !c!     &        +dhead(1,1,itypi,itypj))**2))
27580 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27581 !c!     &        +dhead(2,1,itypi,itypj))**2))
27582
27583
27584 !c!-------------------------------------------------------------------
27585 !c! ecl
27586        write(iout,*) "KURWA2",Rhead
27587        sparrow  = w1 * Qj * om1
27588        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27589        ECL = sparrow / Rhead**2.0d0 &
27590            - hawk    / Rhead**4.0d0
27591 !c!-------------------------------------------------------------------
27592 !c! derivative of ecl is Gcl
27593 !c! dF/dr part
27594        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27595                  + 4.0d0 * hawk    / Rhead**5.0d0
27596 !c! dF/dom1
27597        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27598 !c! dF/dom2
27599        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27600 !c--------------------------------------------------------------------
27601 !c--------------------------------------------------------------------
27602 !c Polarization energy
27603 !c Epol
27604        MomoFac2 = (1.0d0 - chi2 * sqom1)
27605        RR2  = R2 * R2 / MomoFac2
27606        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27607        fgb2 = sqrt(RR2  + a12sq * ee2)
27608        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27609        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27610                / (fgb2 ** 5.0d0)
27611        dFGBdR2 = ( (R2 / MomoFac2)  &
27612                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27613                / (2.0d0 * fgb2)
27614        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27615                 * (2.0d0 - 0.5d0 * ee2) ) &
27616                 / (2.0d0 * fgb2)
27617        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27618 !c!       dPOLdR2 = 0.0d0
27619        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27620 !c!       dPOLdOM1 = 0.0d0
27621        dPOLdOM2 = 0.0d0
27622 !c!-------------------------------------------------------------------
27623 !c! Elj
27624        pom = (pis / Rhead)**6.0d0
27625        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27626 !c! derivative of Elj is Glj
27627        dGLJdR = 4.0d0 * eps_head &
27628            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27629            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27630 !c!-------------------------------------------------------------------
27631
27632 !c! Return the results
27633 !c! (see comments in Eqq)
27634        DO k = 1, 3
27635         erhead(k) = Rhead_distance(k)/Rhead
27636         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27637        END DO
27638        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27639        erdxj = scalar( erhead(1), dC_norm(1,j) )
27640        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27641        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27642        facd1 = d1 * vbld_inv(i+nres)
27643        facd2 = d2 * vbld_inv(j)
27644        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27645        DO k = 1, 3
27646         condor = (erhead_tail(k,2) &
27647        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27648
27649         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27650         gradpepcatx(k,i) = gradpepcatx(k,i) &
27651                   - dGCLdR * pom &
27652                   - dPOLdR2 * (erhead_tail(k,2) &
27653        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27654                   - dGLJdR * pom
27655
27656         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27657 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27658 !                  + dGCLdR * pom &
27659 !                  + dPOLdR2 * condor &
27660 !                  + dGLJdR * pom
27661
27662
27663         gradpepcat(k,i) = gradpepcat(k,i) &
27664                   - dGCLdR * erhead(k) &
27665                   - dPOLdR2 * erhead_tail(k,2) &
27666                   - dGLJdR * erhead(k)
27667
27668         gradpepcat(k,j) = gradpepcat(k,j) &
27669                   + dGCLdR * erhead(k) &
27670                   + dPOLdR2 * erhead_tail(k,2) &
27671                   + dGLJdR * erhead(k)
27672
27673        END DO
27674        RETURN
27675       END SUBROUTINE edq_cat
27676
27677       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27678       use comm_momo
27679       use calc_data
27680
27681       double precision  facd3, adler,ecl,elj,epol
27682        alphapol2 = alphapolcat(itypj,itypi)
27683        w1        = wqdipcat(1,itypi,itypj)
27684        w2        = wqdipcat(2,itypi,itypj)
27685        pis       = sig0headcat(itypi,itypj)
27686        eps_head  = epsheadcat(itypi,itypj)
27687 !c!-------------------------------------------------------------------
27688 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27689        R2 = 0.0d0
27690        DO k = 1, 3
27691 !c! Calculate head-to-tail distances
27692         R2=R2+(chead(k,2)-ctail(k,1))**2
27693        END DO
27694 !c! Pitagoras
27695        R2 = dsqrt(R2)
27696
27697 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27698 !c!     &        +dhead(1,1,itypi,itypj))**2))
27699 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27700 !c!     &        +dhead(2,1,itypi,itypj))**2))
27701
27702
27703 !c!-------------------------------------------------------------------
27704 !c! ecl
27705        sparrow  = w1 * Qj * om1
27706        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27707 !       print *,"CO2", itypi,itypj
27708 !       print *,"CO?!.", w1,w2,Qj,om1
27709        ECL = sparrow / Rhead**2.0d0 &
27710            - hawk    / Rhead**4.0d0
27711 !c!-------------------------------------------------------------------
27712 !c! derivative of ecl is Gcl
27713 !c! dF/dr part
27714        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27715                  + 4.0d0 * hawk    / Rhead**5.0d0
27716 !c! dF/dom1
27717        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27718 !c! dF/dom2
27719        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27720 !c--------------------------------------------------------------------
27721 !c--------------------------------------------------------------------
27722 !c Polarization energy
27723 !c Epol
27724        MomoFac2 = (1.0d0 - chi2 * sqom1)
27725        RR2  = R2 * R2 / MomoFac2
27726        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27727        fgb2 = sqrt(RR2  + a12sq * ee2)
27728        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27729        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27730                / (fgb2 ** 5.0d0)
27731        dFGBdR2 = ( (R2 / MomoFac2)  &
27732                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27733                / (2.0d0 * fgb2)
27734        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27735                 * (2.0d0 - 0.5d0 * ee2) ) &
27736                 / (2.0d0 * fgb2)
27737        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27738 !c!       dPOLdR2 = 0.0d0
27739        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27740 !c!       dPOLdOM1 = 0.0d0
27741        dPOLdOM2 = 0.0d0
27742 !c!-------------------------------------------------------------------
27743 !c! Elj
27744        pom = (pis / Rhead)**6.0d0
27745        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27746 !c! derivative of Elj is Glj
27747        dGLJdR = 4.0d0 * eps_head &
27748            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27749            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27750 !c!-------------------------------------------------------------------
27751
27752 !c! Return the results
27753 !c! (see comments in Eqq)
27754        DO k = 1, 3
27755         erhead(k) = Rhead_distance(k)/Rhead
27756         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27757        END DO
27758        erdxi = scalar( erhead(1), dC_norm(1,i) )
27759        erdxj = scalar( erhead(1), dC_norm(1,j) )
27760        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27761        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27762        facd1 = d1 * vbld_inv(i+1)/2.0
27763        facd2 = d2 * vbld_inv(j)
27764        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27765        DO k = 1, 3
27766         condor = (erhead_tail(k,2) &
27767        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27768
27769         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27770 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27771 !                  - dGCLdR * pom &
27772 !                  - dPOLdR2 * (erhead_tail(k,2) &
27773 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27774 !                  - dGLJdR * pom
27775
27776         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27777 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27778 !                  + dGCLdR * pom &
27779 !                  + dPOLdR2 * condor &
27780 !                  + dGLJdR * pom
27781
27782
27783         gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27784                   - dGCLdR * erhead(k) &
27785                   - dPOLdR2 * erhead_tail(k,2) &
27786                   - dGLJdR * erhead(k))
27787         gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27788                   - dGCLdR * erhead(k) &
27789                   - dPOLdR2 * erhead_tail(k,2) &
27790                   - dGLJdR * erhead(k))
27791
27792
27793         gradpepcat(k,j) = gradpepcat(k,j) &
27794                   + dGCLdR * erhead(k) &
27795                   + dPOLdR2 * erhead_tail(k,2) &
27796                   + dGLJdR * erhead(k)
27797
27798        END DO
27799        RETURN
27800       END SUBROUTINE edq_cat_pep
27801
27802       SUBROUTINE edd(ECL)
27803 !       IMPLICIT NONE
27804        use comm_momo
27805       use calc_data
27806
27807        double precision ecl
27808 !c!       csig = sigiso(itypi,itypj)
27809        w1 = wqdip(1,itypi,itypj)
27810        w2 = wqdip(2,itypi,itypj)
27811 !c!-------------------------------------------------------------------
27812 !c! ECL
27813        fac = (om12 - 3.0d0 * om1 * om2)
27814        c1 = (w1 / (Rhead**3.0d0)) * fac
27815        c2 = (w2 / Rhead ** 6.0d0) &
27816           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27817        ECL = c1 - c2
27818 !c!       write (*,*) "w1 = ", w1
27819 !c!       write (*,*) "w2 = ", w2
27820 !c!       write (*,*) "om1 = ", om1
27821 !c!       write (*,*) "om2 = ", om2
27822 !c!       write (*,*) "om12 = ", om12
27823 !c!       write (*,*) "fac = ", fac
27824 !c!       write (*,*) "c1 = ", c1
27825 !c!       write (*,*) "c2 = ", c2
27826 !c!       write (*,*) "Ecl = ", Ecl
27827 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27828 !c!       write (*,*) "c2_2 = ",
27829 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27830 !c!-------------------------------------------------------------------
27831 !c! dervative of ECL is GCL...
27832 !c! dECL/dr
27833        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27834        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27835           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27836        dGCLdR = c1 - c2
27837 !c! dECL/dom1
27838        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27839        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27840           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27841        dGCLdOM1 = c1 - c2
27842 !c! dECL/dom2
27843        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27844        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27845           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27846        dGCLdOM2 = c1 - c2
27847 !c! dECL/dom12
27848        c1 = w1 / (Rhead ** 3.0d0)
27849        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27850        dGCLdOM12 = c1 - c2
27851 !c!-------------------------------------------------------------------
27852 !c! Return the results
27853 !c! (see comments in Eqq)
27854        DO k= 1, 3
27855         erhead(k) = Rhead_distance(k)/Rhead
27856        END DO
27857        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27858        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27859        facd1 = d1 * vbld_inv(i+nres)
27860        facd2 = d2 * vbld_inv(j+nres)
27861        DO k = 1, 3
27862
27863         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27864         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27865         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27866         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27867
27868         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27869         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27870        END DO
27871        RETURN
27872       END SUBROUTINE edd
27873       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27874 !       IMPLICIT NONE
27875        use comm_momo
27876       use calc_data
27877
27878        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27879        eps_out=80.0d0
27880        itypi = itype(i,1)
27881        itypj = itype(j,1)
27882 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27883 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27884 !c!       t_bath = 300
27885 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27886        Rb=0.001986d0
27887        BetaT = 1.0d0 / (298.0d0 * Rb)
27888 !c! Gay-berne var's
27889        sig0ij = sigma( itypi,itypj )
27890        chi1   = chi( itypi, itypj )
27891        chi2   = chi( itypj, itypi )
27892        chi12  = chi1 * chi2
27893        chip1  = chipp( itypi, itypj )
27894        chip2  = chipp( itypj, itypi )
27895        chip12 = chip1 * chip2
27896 !       chi1=0.0
27897 !       chi2=0.0
27898 !       chi12=0.0
27899 !       chip1=0.0
27900 !       chip2=0.0
27901 !       chip12=0.0
27902 !c! not used by momo potential, but needed by sc_angular which is shared
27903 !c! by all energy_potential subroutines
27904        alf1   = 0.0d0
27905        alf2   = 0.0d0
27906        alf12  = 0.0d0
27907 !c! location, location, location
27908 !       xj  = c( 1, nres+j ) - xi
27909 !       yj  = c( 2, nres+j ) - yi
27910 !       zj  = c( 3, nres+j ) - zi
27911        dxj = dc_norm( 1, nres+j )
27912        dyj = dc_norm( 2, nres+j )
27913        dzj = dc_norm( 3, nres+j )
27914 !c! distance from center of chain(?) to polar/charged head
27915 !c!       write (*,*) "istate = ", 1
27916 !c!       write (*,*) "ii = ", 1
27917 !c!       write (*,*) "jj = ", 1
27918        d1 = dhead(1, 1, itypi, itypj)
27919        d2 = dhead(2, 1, itypi, itypj)
27920 !c! ai*aj from Fgb
27921        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27922 !c!       a12sq = a12sq * a12sq
27923 !c! charge of amino acid itypi is...
27924        Qi  = icharge(itypi)
27925        Qj  = icharge(itypj)
27926        Qij = Qi * Qj
27927 !c! chis1,2,12
27928        chis1 = chis(itypi,itypj)
27929        chis2 = chis(itypj,itypi)
27930        chis12 = chis1 * chis2
27931        sig1 = sigmap1(itypi,itypj)
27932        sig2 = sigmap2(itypi,itypj)
27933 !c!       write (*,*) "sig1 = ", sig1
27934 !c!       write (*,*) "sig2 = ", sig2
27935 !c! alpha factors from Fcav/Gcav
27936        b1cav = alphasur(1,itypi,itypj)
27937 !       b1cav=0.0
27938        b2cav = alphasur(2,itypi,itypj)
27939        b3cav = alphasur(3,itypi,itypj)
27940        b4cav = alphasur(4,itypi,itypj)
27941        wqd = wquad(itypi, itypj)
27942 !c! used by Fgb
27943        eps_in = epsintab(itypi,itypj)
27944        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27945 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27946 !c!-------------------------------------------------------------------
27947 !c! tail location and distance calculations
27948        Rtail = 0.0d0
27949        DO k = 1, 3
27950         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27951         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27952        END DO
27953 !c! tail distances will be themselves usefull elswhere
27954 !c1 (in Gcav, for example)
27955        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27956        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27957        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27958        Rtail = dsqrt(  &
27959           (Rtail_distance(1)*Rtail_distance(1))  &
27960         + (Rtail_distance(2)*Rtail_distance(2))  &
27961         + (Rtail_distance(3)*Rtail_distance(3)))
27962 !c!-------------------------------------------------------------------
27963 !c! Calculate location and distance between polar heads
27964 !c! distance between heads
27965 !c! for each one of our three dimensional space...
27966        d1 = dhead(1, 1, itypi, itypj)
27967        d2 = dhead(2, 1, itypi, itypj)
27968
27969        DO k = 1,3
27970 !c! location of polar head is computed by taking hydrophobic centre
27971 !c! and moving by a d1 * dc_norm vector
27972 !c! see unres publications for very informative images
27973         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27974         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27975 !c! distance
27976 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27977 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27978         Rhead_distance(k) = chead(k,2) - chead(k,1)
27979        END DO
27980 !c! pitagoras (root of sum of squares)
27981        Rhead = dsqrt(   &
27982           (Rhead_distance(1)*Rhead_distance(1)) &
27983         + (Rhead_distance(2)*Rhead_distance(2)) &
27984         + (Rhead_distance(3)*Rhead_distance(3)))
27985 !c!-------------------------------------------------------------------
27986 !c! zero everything that should be zero'ed
27987        Egb = 0.0d0
27988        ECL = 0.0d0
27989        Elj = 0.0d0
27990        Equad = 0.0d0
27991        Epol = 0.0d0
27992        eheadtail = 0.0d0
27993        dGCLdOM1 = 0.0d0
27994        dGCLdOM2 = 0.0d0
27995        dGCLdOM12 = 0.0d0
27996        dPOLdOM1 = 0.0d0
27997        dPOLdOM2 = 0.0d0
27998        RETURN
27999       END SUBROUTINE elgrad_init
28000
28001
28002       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28003       use comm_momo
28004       use calc_data
28005        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28006        eps_out=80.0d0
28007        itypi = itype(i,1)
28008        itypj = itype(j,5)
28009 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28010 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28011 !c!       t_bath = 300
28012 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28013        Rb=0.001986d0
28014        BetaT = 1.0d0 / (298.0d0 * Rb)
28015 !c! Gay-berne var's
28016        sig0ij = sigmacat( itypi,itypj )
28017        chi1   = chi1cat( itypi, itypj )
28018        chi2   = 0.0d0
28019        chi12  = 0.0d0
28020        chip1  = chipp1cat( itypi, itypj )
28021        chip2  = 0.0d0
28022        chip12 = 0.0d0
28023 !c! not used by momo potential, but needed by sc_angular which is shared
28024 !c! by all energy_potential subroutines
28025        alf1   = 0.0d0
28026        alf2   = 0.0d0
28027        alf12  = 0.0d0
28028        dxj = dc_norm( 1, nres+j )
28029        dyj = dc_norm( 2, nres+j )
28030        dzj = dc_norm( 3, nres+j )
28031 !c! distance from center of chain(?) to polar/charged head
28032        d1 = dheadcat(1, 1, itypi, itypj)
28033        d2 = dheadcat(2, 1, itypi, itypj)
28034 !c! ai*aj from Fgb
28035        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28036 !c!       a12sq = a12sq * a12sq
28037 !c! charge of amino acid itypi is...
28038        Qi  = icharge(itypi)
28039        Qj  = ichargecat(itypj)
28040        Qij = Qi * Qj
28041 !c! chis1,2,12
28042        chis1 = chis1cat(itypi,itypj)
28043        chis2 = 0.0d0
28044        chis12 = 0.0d0
28045        sig1 = sigmap1cat(itypi,itypj)
28046        sig2 = sigmap2cat(itypi,itypj)
28047 !c! alpha factors from Fcav/Gcav
28048        b1cav = alphasurcat(1,itypi,itypj)
28049        b2cav = alphasurcat(2,itypi,itypj)
28050        b3cav = alphasurcat(3,itypi,itypj)
28051        b4cav = alphasurcat(4,itypi,itypj)
28052        wqd = wquadcat(itypi, itypj)
28053 !c! used by Fgb
28054        eps_in = epsintabcat(itypi,itypj)
28055        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28056 !c!-------------------------------------------------------------------
28057 !c! tail location and distance calculations
28058        Rtail = 0.0d0
28059        DO k = 1, 3
28060         ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
28061         ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28062        END DO
28063 !c! tail distances will be themselves usefull elswhere
28064 !c1 (in Gcav, for example)
28065        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28066        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28067        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28068        Rtail = dsqrt(  &
28069           (Rtail_distance(1)*Rtail_distance(1))  &
28070         + (Rtail_distance(2)*Rtail_distance(2))  &
28071         + (Rtail_distance(3)*Rtail_distance(3)))
28072 !c!-------------------------------------------------------------------
28073 !c! Calculate location and distance between polar heads
28074 !c! distance between heads
28075 !c! for each one of our three dimensional space...
28076        d1 = dheadcat(1, 1, itypi, itypj)
28077        d2 = dheadcat(2, 1, itypi, itypj)
28078
28079        DO k = 1,3
28080 !c! location of polar head is computed by taking hydrophobic centre
28081 !c! and moving by a d1 * dc_norm vector
28082 !c! see unres publications for very informative images
28083         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28084         chead(k,2) = c(k, j)
28085 !c! distance
28086 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28087 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28088         Rhead_distance(k) = chead(k,2) - chead(k,1)
28089        END DO
28090 !c! pitagoras (root of sum of squares)
28091        Rhead = dsqrt(   &
28092           (Rhead_distance(1)*Rhead_distance(1)) &
28093         + (Rhead_distance(2)*Rhead_distance(2)) &
28094         + (Rhead_distance(3)*Rhead_distance(3)))
28095 !c!-------------------------------------------------------------------
28096 !c! zero everything that should be zero'ed
28097        Egb = 0.0d0
28098        ECL = 0.0d0
28099        Elj = 0.0d0
28100        Equad = 0.0d0
28101        Epol = 0.0d0
28102        eheadtail = 0.0d0
28103        dGCLdOM1 = 0.0d0
28104        dGCLdOM2 = 0.0d0
28105        dGCLdOM12 = 0.0d0
28106        dPOLdOM1 = 0.0d0
28107        dPOLdOM2 = 0.0d0
28108        RETURN
28109       END SUBROUTINE elgrad_init_cat
28110
28111       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28112       use comm_momo
28113       use calc_data
28114        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28115        eps_out=80.0d0
28116        itypi = 10
28117        itypj = itype(j,5)
28118 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28119 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28120 !c!       t_bath = 300
28121 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28122        Rb=0.001986d0
28123        BetaT = 1.0d0 / (298.0d0 * Rb)
28124 !c! Gay-berne var's
28125        sig0ij = sigmacat( itypi,itypj )
28126        chi1   = chi1cat( itypi, itypj )
28127        chi2   = 0.0d0
28128        chi12  = 0.0d0
28129        chip1  = chipp1cat( itypi, itypj )
28130        chip2  = 0.0d0
28131        chip12 = 0.0d0
28132 !c! not used by momo potential, but needed by sc_angular which is shared
28133 !c! by all energy_potential subroutines
28134        alf1   = 0.0d0
28135        alf2   = 0.0d0
28136        alf12  = 0.0d0
28137        dxj = 0.0d0 !dc_norm( 1, nres+j )
28138        dyj = 0.0d0 !dc_norm( 2, nres+j )
28139        dzj = 0.0d0 !dc_norm( 3, nres+j )
28140 !c! distance from center of chain(?) to polar/charged head
28141        d1 = dheadcat(1, 1, itypi, itypj)
28142        d2 = dheadcat(2, 1, itypi, itypj)
28143 !c! ai*aj from Fgb
28144        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28145 !c!       a12sq = a12sq * a12sq
28146 !c! charge of amino acid itypi is...
28147        Qi  = 0
28148        Qj  = ichargecat(itypj)
28149 !       Qij = Qi * Qj
28150 !c! chis1,2,12
28151        chis1 = chis1cat(itypi,itypj)
28152        chis2 = 0.0d0
28153        chis12 = 0.0d0
28154        sig1 = sigmap1cat(itypi,itypj)
28155        sig2 = sigmap2cat(itypi,itypj)
28156 !c! alpha factors from Fcav/Gcav
28157        b1cav = alphasurcat(1,itypi,itypj)
28158        b2cav = alphasurcat(2,itypi,itypj)
28159        b3cav = alphasurcat(3,itypi,itypj)
28160        b4cav = alphasurcat(4,itypi,itypj)
28161        wqd = wquadcat(itypi, itypj)
28162 !c! used by Fgb
28163        eps_in = epsintabcat(itypi,itypj)
28164        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28165 !c!-------------------------------------------------------------------
28166 !c! tail location and distance calculations
28167        Rtail = 0.0d0
28168        DO k = 1, 3
28169         ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
28170         ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28171        END DO
28172 !c! tail distances will be themselves usefull elswhere
28173 !c1 (in Gcav, for example)
28174        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28175        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28176        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28177        Rtail = dsqrt(  &
28178           (Rtail_distance(1)*Rtail_distance(1))  &
28179         + (Rtail_distance(2)*Rtail_distance(2))  &
28180         + (Rtail_distance(3)*Rtail_distance(3)))
28181 !c!-------------------------------------------------------------------
28182 !c! Calculate location and distance between polar heads
28183 !c! distance between heads
28184 !c! for each one of our three dimensional space...
28185        d1 = dheadcat(1, 1, itypi, itypj)
28186        d2 = dheadcat(2, 1, itypi, itypj)
28187
28188        DO k = 1,3
28189 !c! location of polar head is computed by taking hydrophobic centre
28190 !c! and moving by a d1 * dc_norm vector
28191 !c! see unres publications for very informative images
28192         chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
28193         chead(k,2) = c(k, j)
28194 !c! distance
28195 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28196 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28197         Rhead_distance(k) = chead(k,2) - chead(k,1)
28198        END DO
28199 !c! pitagoras (root of sum of squares)
28200        Rhead = dsqrt(   &
28201           (Rhead_distance(1)*Rhead_distance(1)) &
28202         + (Rhead_distance(2)*Rhead_distance(2)) &
28203         + (Rhead_distance(3)*Rhead_distance(3)))
28204 !c!-------------------------------------------------------------------
28205 !c! zero everything that should be zero'ed
28206        Egb = 0.0d0
28207        ECL = 0.0d0
28208        Elj = 0.0d0
28209        Equad = 0.0d0
28210        Epol = 0.0d0
28211        eheadtail = 0.0d0
28212        dGCLdOM1 = 0.0d0
28213        dGCLdOM2 = 0.0d0
28214        dGCLdOM12 = 0.0d0
28215        dPOLdOM1 = 0.0d0
28216        dPOLdOM2 = 0.0d0
28217        RETURN
28218       END SUBROUTINE elgrad_init_cat_pep
28219
28220       double precision function tschebyshev(m,n,x,y)
28221       implicit none
28222       integer i,m,n
28223       double precision x(n),y,yy(0:maxvar),aux
28224 !c Tschebyshev polynomial. Note that the first term is omitted
28225 !c m=0: the constant term is included
28226 !c m=1: the constant term is not included
28227       yy(0)=1.0d0
28228       yy(1)=y
28229       do i=2,n
28230         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
28231       enddo
28232       aux=0.0d0
28233       do i=m,n
28234         aux=aux+x(i)*yy(i)
28235       enddo
28236       tschebyshev=aux
28237       return
28238       end function tschebyshev
28239 !C--------------------------------------------------------------------------
28240       double precision function gradtschebyshev(m,n,x,y)
28241       implicit none
28242       integer i,m,n
28243       double precision x(n+1),y,yy(0:maxvar),aux
28244 !c Tschebyshev polynomial. Note that the first term is omitted
28245 !c m=0: the constant term is included
28246 !c m=1: the constant term is not included
28247       yy(0)=1.0d0
28248       yy(1)=2.0d0*y
28249       do i=2,n
28250         yy(i)=2*y*yy(i-1)-yy(i-2)
28251       enddo
28252       aux=0.0d0
28253       do i=m,n
28254         aux=aux+x(i+1)*yy(i)*(i+1)
28255 !C        print *, x(i+1),yy(i),i
28256       enddo
28257       gradtschebyshev=aux
28258       return
28259       end function gradtschebyshev
28260
28261       subroutine make_SCSC_inter_list
28262       include 'mpif.h'
28263       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28264       real*8 :: dist_init, dist_temp,r_buff_list
28265       integer:: contlisti(200*nres),contlistj(200*nres)
28266 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
28267       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
28268       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
28269 !            print *,"START make_SC"
28270           r_buff_list=5.0
28271             ilist_sc=0
28272             do i=iatsc_s,iatsc_e
28273              itypi=iabs(itype(i,1))
28274              if (itypi.eq.ntyp1) cycle
28275              xi=c(1,nres+i)
28276              yi=c(2,nres+i)
28277              zi=c(3,nres+i)
28278              xi=dmod(xi,boxxsize)
28279              if (xi.lt.0) xi=xi+boxxsize
28280              yi=dmod(yi,boxysize)
28281              if (yi.lt.0) yi=yi+boxysize
28282              zi=dmod(zi,boxzsize)
28283              if (zi.lt.0) zi=zi+boxzsize
28284              do iint=1,nint_gr(i)
28285               do j=istart(i,iint),iend(i,iint)
28286                itypj=iabs(itype(j,1))
28287                if (itypj.eq.ntyp1) cycle
28288                xj=c(1,nres+j)
28289                yj=c(2,nres+j)
28290                zj=c(3,nres+j)
28291                xj=dmod(xj,boxxsize)
28292                if (xj.lt.0) xj=xj+boxxsize
28293                yj=dmod(yj,boxysize)
28294                if (yj.lt.0) yj=yj+boxysize
28295                zj=dmod(zj,boxzsize)
28296                if (zj.lt.0) zj=zj+boxzsize
28297                dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28298                xj_safe=xj
28299                yj_safe=yj
28300                zj_safe=zj
28301                subchap=0
28302                do xshift=-1,1
28303                do yshift=-1,1
28304                do zshift=-1,1
28305                xj=xj_safe+xshift*boxxsize
28306                yj=yj_safe+yshift*boxysize
28307                zj=zj_safe+zshift*boxzsize
28308                dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28309                if(dist_temp.lt.dist_init) then
28310                 dist_init=dist_temp
28311                 xj_temp=xj
28312                 yj_temp=yj
28313                 zj_temp=zj
28314                 subchap=1
28315                endif
28316                enddo
28317                enddo
28318                enddo
28319                if (subchap.eq.1) then
28320                xj=xj_temp-xi
28321                yj=yj_temp-yi
28322                zj=zj_temp-zi
28323                else
28324                xj=xj_safe-xi
28325                yj=yj_safe-yi
28326                zj=zj_safe-zi
28327                endif
28328 ! r_buff_list is a read value for a buffer
28329                if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28330 ! Here the list is created
28331                  ilist_sc=ilist_sc+1
28332 ! this can be substituted by cantor and anti-cantor
28333                  contlisti(ilist_sc)=i
28334                  contlistj(ilist_sc)=j
28335
28336                endif
28337              enddo
28338              enddo
28339              enddo
28340 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28341 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28342 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
28343 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
28344 #ifdef DEBUG
28345       write (iout,*) "before MPIREDUCE",ilist_sc
28346       do i=1,ilist_sc
28347       write (iout,*) i,contlisti(i),contlistj(i)
28348       enddo
28349 #endif
28350       if (nfgtasks.gt.1)then
28351
28352         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28353           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28354 !        write(iout,*) "before bcast",g_ilist_sc
28355         call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
28356                         i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
28357         displ(0)=0
28358         do i=1,nfgtasks-1,1
28359           displ(i)=i_ilist_sc(i-1)+displ(i-1)
28360         enddo
28361 !        write(iout,*) "before gather",displ(0),displ(1)
28362         call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
28363                          newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
28364                          king,FG_COMM,IERR)
28365         call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
28366                          newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
28367                          king,FG_COMM,IERR)
28368         call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
28369 !        write(iout,*) "before bcast",g_ilist_sc
28370 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28371         call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28372         call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28373
28374 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28375
28376         else
28377         g_ilist_sc=ilist_sc
28378
28379         do i=1,ilist_sc
28380         newcontlisti(i)=contlisti(i)
28381         newcontlistj(i)=contlistj(i)
28382         enddo
28383         endif
28384
28385 #ifdef DEBUG
28386       write (iout,*) "after MPIREDUCE",g_ilist_sc
28387       do i=1,g_ilist_sc
28388       write (iout,*) i,newcontlisti(i),newcontlistj(i)
28389       enddo
28390 #endif
28391         call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
28392       return
28393       end subroutine make_SCSC_inter_list
28394 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28395
28396       subroutine make_SCp_inter_list
28397       use MD_data,  only: itime_mat
28398
28399       include 'mpif.h'
28400       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28401       real*8 :: dist_init, dist_temp,r_buff_list
28402       integer:: contlistscpi(200*nres),contlistscpj(200*nres)
28403 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
28404       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
28405       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
28406 !            print *,"START make_SC"
28407       r_buff_list=5.0
28408             ilist_scp=0
28409       do i=iatscp_s,iatscp_e
28410         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28411         xi=0.5D0*(c(1,i)+c(1,i+1))
28412         yi=0.5D0*(c(2,i)+c(2,i+1))
28413         zi=0.5D0*(c(3,i)+c(3,i+1))
28414           xi=mod(xi,boxxsize)
28415           if (xi.lt.0) xi=xi+boxxsize
28416           yi=mod(yi,boxysize)
28417           if (yi.lt.0) yi=yi+boxysize
28418           zi=mod(zi,boxzsize)
28419           if (zi.lt.0) zi=zi+boxzsize
28420
28421         do iint=1,nscp_gr(i)
28422
28423         do j=iscpstart(i,iint),iscpend(i,iint)
28424           itypj=iabs(itype(j,1))
28425           if (itypj.eq.ntyp1) cycle
28426 ! Uncomment following three lines for SC-p interactions
28427 !         xj=c(1,nres+j)-xi
28428 !         yj=c(2,nres+j)-yi
28429 !         zj=c(3,nres+j)-zi
28430 ! Uncomment following three lines for Ca-p interactions
28431 !          xj=c(1,j)-xi
28432 !          yj=c(2,j)-yi
28433 !          zj=c(3,j)-zi
28434           xj=c(1,j)
28435           yj=c(2,j)
28436           zj=c(3,j)
28437           xj=mod(xj,boxxsize)
28438           if (xj.lt.0) xj=xj+boxxsize
28439           yj=mod(yj,boxysize)
28440           if (yj.lt.0) yj=yj+boxysize
28441           zj=mod(zj,boxzsize)
28442           if (zj.lt.0) zj=zj+boxzsize
28443       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28444       xj_safe=xj
28445       yj_safe=yj
28446       zj_safe=zj
28447       subchap=0
28448       do xshift=-1,1
28449       do yshift=-1,1
28450       do zshift=-1,1
28451           xj=xj_safe+xshift*boxxsize
28452           yj=yj_safe+yshift*boxysize
28453           zj=zj_safe+zshift*boxzsize
28454           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28455           if(dist_temp.lt.dist_init) then
28456             dist_init=dist_temp
28457             xj_temp=xj
28458             yj_temp=yj
28459             zj_temp=zj
28460             subchap=1
28461           endif
28462        enddo
28463        enddo
28464        enddo
28465        if (subchap.eq.1) then
28466           xj=xj_temp-xi
28467           yj=yj_temp-yi
28468           zj=zj_temp-zi
28469        else
28470           xj=xj_safe-xi
28471           yj=yj_safe-yi
28472           zj=zj_safe-zi
28473        endif
28474 #ifdef DEBUG
28475                 ! r_buff_list is a read value for a buffer
28476                if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
28477 ! Here the list is created
28478                  ilist_scp_first=ilist_scp_first+1
28479 ! this can be substituted by cantor and anti-cantor
28480                  contlistscpi_f(ilist_scp_first)=i
28481                  contlistscpj_f(ilist_scp_first)=j
28482               endif
28483 #endif
28484 ! r_buff_list is a read value for a buffer
28485                if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28486 ! Here the list is created
28487                  ilist_scp=ilist_scp+1
28488 ! this can be substituted by cantor and anti-cantor
28489                  contlistscpi(ilist_scp)=i
28490                  contlistscpj(ilist_scp)=j
28491               endif
28492              enddo
28493              enddo
28494              enddo
28495 #ifdef DEBUG
28496       write (iout,*) "before MPIREDUCE",ilist_scp
28497       do i=1,ilist_scp
28498       write (iout,*) i,contlistscpi(i),contlistscpj(i)
28499       enddo
28500 #endif
28501       if (nfgtasks.gt.1)then
28502
28503         call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
28504           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28505 !        write(iout,*) "before bcast",g_ilist_sc
28506         call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
28507                         i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
28508         displ(0)=0
28509         do i=1,nfgtasks-1,1
28510           displ(i)=i_ilist_scp(i-1)+displ(i-1)
28511         enddo
28512 !        write(iout,*) "before gather",displ(0),displ(1)
28513         call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
28514                          newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
28515                          king,FG_COMM,IERR)
28516         call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
28517                          newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
28518                          king,FG_COMM,IERR)
28519         call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
28520 !        write(iout,*) "before bcast",g_ilist_sc
28521 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28522         call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28523         call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28524
28525 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28526
28527         else
28528         g_ilist_scp=ilist_scp
28529
28530         do i=1,ilist_scp
28531         newcontlistscpi(i)=contlistscpi(i)
28532         newcontlistscpj(i)=contlistscpj(i)
28533         enddo
28534         endif
28535
28536 #ifdef DEBUG
28537       write (iout,*) "after MPIREDUCE",g_ilist_scp
28538       do i=1,g_ilist_scp
28539       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
28540       enddo
28541
28542 !      if (ifirstrun.eq.0) ifirstrun=1
28543 !      do i=1,ilist_scp_first
28544 !       do j=1,g_ilist_scp
28545 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
28546 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
28547 !        enddo
28548 !       print *,itime_mat,"ERROR matrix needs updating"
28549 !       print *,contlistscpi_f(i),contlistscpj_f(i)
28550 !  126  continue
28551 !      enddo
28552 #endif
28553         call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
28554
28555       return
28556       end subroutine make_SCp_inter_list
28557
28558 !-----------------------------------------------------------------------------
28559 !-----------------------------------------------------------------------------
28560
28561
28562       subroutine make_pp_inter_list
28563       include 'mpif.h'
28564       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28565       real*8 :: xmedj,ymedj,zmedj
28566       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
28567       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
28568       integer:: contlistppi(200*nres),contlistppj(200*nres)
28569 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
28570       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
28571       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
28572 !            print *,"START make_SC"
28573             ilist_pp=0
28574       r_buff_list=5.0
28575       do i=iatel_s,iatel_e
28576         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28577         dxi=dc(1,i)
28578         dyi=dc(2,i)
28579         dzi=dc(3,i)
28580         dx_normi=dc_norm(1,i)
28581         dy_normi=dc_norm(2,i)
28582         dz_normi=dc_norm(3,i)
28583         xmedi=c(1,i)+0.5d0*dxi
28584         ymedi=c(2,i)+0.5d0*dyi
28585         zmedi=c(3,i)+0.5d0*dzi
28586           xmedi=dmod(xmedi,boxxsize)
28587           if (xmedi.lt.0) xmedi=xmedi+boxxsize
28588           ymedi=dmod(ymedi,boxysize)
28589           if (ymedi.lt.0) ymedi=ymedi+boxysize
28590           zmedi=dmod(zmedi,boxzsize)
28591           if (zmedi.lt.0) zmedi=zmedi+boxzsize
28592              do j=ielstart(i),ielend(i)
28593 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28594           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28595
28596 ! 1,j)
28597           dxj=dc(1,j)
28598           dyj=dc(2,j)
28599           dzj=dc(3,j)
28600           dx_normj=dc_norm(1,j)
28601           dy_normj=dc_norm(2,j)
28602           dz_normj=dc_norm(3,j)
28603 !          xj=c(1,j)+0.5D0*dxj-xmedi
28604 !          yj=c(2,j)+0.5D0*dyj-ymedi
28605 !          zj=c(3,j)+0.5D0*dzj-zmedi
28606           xj=c(1,j)+0.5D0*dxj
28607           yj=c(2,j)+0.5D0*dyj
28608           zj=c(3,j)+0.5D0*dzj
28609           xj=mod(xj,boxxsize)
28610           if (xj.lt.0) xj=xj+boxxsize
28611           yj=mod(yj,boxysize)
28612           if (yj.lt.0) yj=yj+boxysize
28613           zj=mod(zj,boxzsize)
28614           if (zj.lt.0) zj=zj+boxzsize
28615
28616       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
28617       xj_safe=xj
28618       yj_safe=yj
28619       zj_safe=zj
28620       do xshift=-1,1
28621       do yshift=-1,1
28622       do zshift=-1,1
28623           xj=xj_safe+xshift*boxxsize
28624           yj=yj_safe+yshift*boxysize
28625           zj=zj_safe+zshift*boxzsize
28626           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
28627           if(dist_temp.lt.dist_init) then
28628             dist_init=dist_temp
28629             xj_temp=xj
28630             yj_temp=yj
28631             zj_temp=zj
28632           endif
28633        enddo
28634        enddo
28635        enddo
28636
28637       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28638 ! Here the list is created
28639                  ilist_pp=ilist_pp+1
28640 ! this can be substituted by cantor and anti-cantor
28641                  contlistppi(ilist_pp)=i
28642                  contlistppj(ilist_pp)=j
28643               endif
28644              enddo
28645              enddo
28646 !             enddo
28647 #ifdef DEBUG
28648       write (iout,*) "before MPIREDUCE",ilist_pp
28649       do i=1,ilist_pp
28650       write (iout,*) i,contlistppi(i),contlistppj(i)
28651       enddo
28652 #endif
28653       if (nfgtasks.gt.1)then
28654
28655         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
28656           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28657 !        write(iout,*) "before bcast",g_ilist_sc
28658         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
28659                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
28660         displ(0)=0
28661         do i=1,nfgtasks-1,1
28662           displ(i)=i_ilist_pp(i-1)+displ(i-1)
28663         enddo
28664 !        write(iout,*) "before gather",displ(0),displ(1)
28665         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
28666                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
28667                          king,FG_COMM,IERR)
28668         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
28669                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
28670                          king,FG_COMM,IERR)
28671         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
28672 !        write(iout,*) "before bcast",g_ilist_sc
28673 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28674         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28675         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28676
28677 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28678
28679         else
28680         g_ilist_pp=ilist_pp
28681
28682         do i=1,ilist_pp
28683         newcontlistppi(i)=contlistppi(i)
28684         newcontlistppj(i)=contlistppj(i)
28685         enddo
28686         endif
28687         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
28688 #ifdef DEBUG
28689       write (iout,*) "after MPIREDUCE",g_ilist_pp
28690       do i=1,g_ilist_pp
28691       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
28692       enddo
28693 #endif
28694       return
28695       end subroutine make_pp_inter_list
28696
28697 !-----------------------------------------------------------------------------
28698 !-----------------------------------------------------------------------------
28699
28700
28701
28702       end module energy