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,gradnuclcat,gradnuclcatx
 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                       ecation_nucl
 252 ! energies for protein nucleic acid interaction
 253       real(kind=8) :: escbase,epepbase,escpho,epeppho
 254
 255 #ifdef MPI
 256       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 257 ! shielding effect varibles for MPI
 258       real(kind=8) ::  fac_shieldbuf(nres), &
 259       grad_shield_locbuf1(3*maxcontsshi*nres), &
 260       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 261       grad_shield_locbuf2(3*maxcontsshi*nres), &
 262       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 263       grad_shieldbuf1(3*nres), &
 264       grad_shieldbuf2(3*nres)
 265
 266        integer ishield_listbuf(-1:nres), &
 267        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 268 !       print *,"I START ENERGY"
 269        imatupdate=100
 270 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 271 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 272 !      real(kind=8), dimension(:,:,:),allocatable:: &
 273 !       grad_shield_locbuf,grad_shield_sidebuf
 274 !      real(kind=8), dimension(:,:),allocatable:: &
 275 !        grad_shieldbuf
 276 !       integer, dimension(:),allocatable:: &
 277 !       ishield_listbuf
 278 !       integer, dimension(:,:),allocatable::  shield_listbuf
 279 !       integer :: k,j,i
 280 !      if (.not.allocated(fac_shieldbuf)) then
 281 !          allocate(fac_shieldbuf(nres))
 282 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 283 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 284 !          allocate(grad_shieldbuf(3,-1:nres))
 285 !          allocate(ishield_listbuf(nres))
 286 !          allocate(shield_listbuf(maxcontsshi,nres))
 287 !       endif
 288
 289 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 290 !     & " nfgtasks",nfgtasks
 291       if (nfgtasks.gt.1) then
 292         time00=MPI_Wtime()
 293 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 294         if (fg_rank.eq.0) then
 295           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 296 !          print *,"Processor",myrank," BROADCAST iorder"
 297 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 298 ! FG slaves as WEIGHTS array.
 299           weights_(1)=wsc
 300           weights_(2)=wscp
 301           weights_(3)=welec
 302           weights_(4)=wcorr
 303           weights_(5)=wcorr5
 304           weights_(6)=wcorr6
 305           weights_(7)=wel_loc
 306           weights_(8)=wturn3
 307           weights_(9)=wturn4
 308           weights_(10)=wturn6
 309           weights_(11)=wang
 310           weights_(12)=wscloc
 311           weights_(13)=wtor
 312           weights_(14)=wtor_d
 313           weights_(15)=wstrain
 314           weights_(16)=wvdwpp
 315           weights_(17)=wbond
 316           weights_(18)=scal14
 317           weights_(21)=wsccor
 318           weights_(26)=wvdwpp_nucl
 319           weights_(27)=welpp
 320           weights_(28)=wvdwpsb
 321           weights_(29)=welpsb
 322           weights_(30)=wvdwsb
 323           weights_(31)=welsb
 324           weights_(32)=wbond_nucl
 325           weights_(33)=wang_nucl
 326           weights_(34)=wsbloc
 327           weights_(35)=wtor_nucl
 328           weights_(36)=wtor_d_nucl
 329           weights_(37)=wcorr_nucl
 330           weights_(38)=wcorr3_nucl
 331           weights_(41)=wcatcat
 332           weights_(42)=wcatprot
 333           weights_(46)=wscbase
 334           weights_(47)=wpepbase
 335           weights_(48)=wscpho
 336           weights_(49)=wpeppho
 337           weights_(50)=wcatnucl
 338 !          wcatcat= weights(41)
 339 !          wcatprot=weights(42)
 340
 341 ! FG Master broadcasts the WEIGHTS_ array
 342           call MPI_Bcast(weights_(1),n_ene,&
 343              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 344         else
 345 ! FG slaves receive the WEIGHTS array
 346           call MPI_Bcast(weights(1),n_ene,&
 347               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 348           wsc=weights(1)
 349           wscp=weights(2)
 350           welec=weights(3)
 351           wcorr=weights(4)
 352           wcorr5=weights(5)
 353           wcorr6=weights(6)
 354           wel_loc=weights(7)
 355           wturn3=weights(8)
 356           wturn4=weights(9)
 357           wturn6=weights(10)
 358           wang=weights(11)
 359           wscloc=weights(12)
 360           wtor=weights(13)
 361           wtor_d=weights(14)
 362           wstrain=weights(15)
 363           wvdwpp=weights(16)
 364           wbond=weights(17)
 365           scal14=weights(18)
 366           wsccor=weights(21)
 367           wvdwpp_nucl =weights(26)
 368           welpp  =weights(27)
 369           wvdwpsb=weights(28)
 370           welpsb =weights(29)
 371           wvdwsb =weights(30)
 372           welsb  =weights(31)
 373           wbond_nucl  =weights(32)
 374           wang_nucl   =weights(33)
 375           wsbloc =weights(34)
 376           wtor_nucl   =weights(35)
 377           wtor_d_nucl =weights(36)
 378           wcorr_nucl  =weights(37)
 379           wcorr3_nucl =weights(38)
 380           wcatcat= weights(41)
 381           wcatprot=weights(42)
 382           wscbase=weights(46)
 383           wpepbase=weights(47)
 384           wscpho=weights(48)
 385           wpeppho=weights(49)
 386           wcatnucl=weights(50)
 387 !      welpsb=weights(28)*fact(1)
 388 !
 389 !      wcorr_nucl= weights(37)*fact(1)
 390 !     wcorr3_nucl=weights(38)*fact(2)
 391 !     wtor_nucl=  weights(35)*fact(1)
 392 !     wtor_d_nucl=weights(36)*fact(2)
 393
 394         endif
 395         time_Bcast=time_Bcast+MPI_Wtime()-time00
 396         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 397 !        call chainbuild_cart
 398       endif
 399 !       print *,"itime_mat",itime_mat,imatupdate
 400         if (nfgtasks.gt.1) then
 401         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 402         endif
 403        if (nres_molec(1).gt.0) then
 404        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 405 !       write (iout,*) "after make_SCp_inter_list"
 406        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 407 !       write (iout,*) "after make_SCSC_inter_list"
 408
 409        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 410        endif
 411 !       write (iout,*) "after make_pp_inter_list"
 412
 413 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 414 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 415 #else
 416 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 417 !        call int_from_cart1(.false.)
 418 !      endif
 419 #endif
 420 #ifdef TIMING
 421       time00=MPI_Wtime()
 422 #endif
 423 !
 424 ! Compute the side-chain and electrostatic interaction energy
 425 !        print *, "Before EVDW"
 426 !      goto (101,102,103,104,105,106) ipot
 427       select case(ipot)
 428 ! Lennard-Jones potential.
 429 !  101 call elj(evdw)
 430        case (1)
 431          call elj(evdw)
 432 !d    print '(a)','Exit ELJcall el'
 433 !      goto 107
 434 ! Lennard-Jones-Kihara potential (shifted).
 435 !  102 call eljk(evdw)
 436        case (2)
 437          call eljk(evdw)
 438 !      goto 107
 439 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 440 !  103 call ebp(evdw)
 441        case (3)
 442          call ebp(evdw)
 443 !      goto 107
 444 ! Gay-Berne potential (shifted LJ, angular dependence).
 445 !  104 call egb(evdw)
 446        case (4)
 447 !       print *,"MOMO",scelemode
 448         if (scelemode.eq.0) then
 449          call egb(evdw)
 450         else
 451          call emomo(evdw)
 452         endif
 453 !      goto 107
 454 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 455 !  105 call egbv(evdw)
 456        case (5)
 457          call egbv(evdw)
 458 !      goto 107
 459 ! Soft-sphere potential
 460 !  106 call e_softsphere(evdw)
 461        case (6)
 462          call e_softsphere(evdw)
 463 !
 464 ! Calculate electrostatic (H-bonding) energy of the main chain.
 465 !
 466 !  107 continue
 467        case default
 468          write(iout,*)"Wrong ipot"
 469 !         return
 470 !   50 continue
 471       end select
 472 !      continue
 473 !        print *,"after EGB"
 474 ! shielding effect
 475        if (shield_mode.eq.2) then
 476                  call set_shield_fac2
 477
 478       if (nfgtasks.gt.1) then
 479       grad_shield_sidebuf1(:)=0.0d0
 480       grad_shield_locbuf1(:)=0.0d0
 481       grad_shield_sidebuf2(:)=0.0d0
 482       grad_shield_locbuf2(:)=0.0d0
 483       grad_shieldbuf1(:)=0.0d0
 484       grad_shieldbuf2(:)=0.0d0
 485 !#define DEBUG
 486 #ifdef DEBUG
 487        write(iout,*) "befor reduce fac_shield reduce"
 488        do i=1,nres
 489         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 490         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 491        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 492        enddo
 493 #endif
 494         iii=0
 495         jjj=0
 496         do i=1,nres
 497         ishield_listbuf(i)=0
 498         do k=1,3
 499         iii=iii+1
 500         grad_shieldbuf1(iii)=grad_shield(k,i)
 501         enddo
 502         enddo
 503         do i=1,nres
 504          do j=1,maxcontsshi
 505           do k=1,3
 506               jjj=jjj+1
 507               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 508               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 509            enddo
 510           enddo
 511          enddo
 512         call MPI_Allgatherv(fac_shield(ivec_start), &
 513         ivec_count(fg_rank1), &
 514         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 515         ivec_displ(0), &
 516         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 517         call MPI_Allgatherv(shield_list(1,ivec_start), &
 518         ivec_count(fg_rank1), &
 519         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 520         ivec_displ(0), &
 521         MPI_I50,FG_COMM,IERROR)
 522 !        write(2,*) "After I50"
 523 !        call flush(iout)
 524         call MPI_Allgatherv(ishield_list(ivec_start), &
 525         ivec_count(fg_rank1), &
 526         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 527         ivec_displ(0), &
 528         MPI_INTEGER,FG_COMM,IERROR)
 529 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 530
 531 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 532 !        write (2,*) "before"
 533 !        write(2,*) grad_shieldbuf1
 534 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 535 !        ivec_count(fg_rank1)*3, &
 536 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 537 !        ivec_count(0), &
 538 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 539         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 540         nres*3, &
 541         MPI_DOUBLE_PRECISION, &
 542         MPI_SUM, &
 543         FG_COMM,IERROR)
 544         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 545         nres*3*maxcontsshi, &
 546         MPI_DOUBLE_PRECISION, &
 547         MPI_SUM, &
 548         FG_COMM,IERROR)
 549
 550         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 551         nres*3*maxcontsshi, &
 552         MPI_DOUBLE_PRECISION, &
 553         MPI_SUM, &
 554         FG_COMM,IERROR)
 555
 556 !        write(2,*) "after"
 557 !        write(2,*) grad_shieldbuf2
 558
 559 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 560 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 561 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 562 !        ivec_displ(0)*3*maxcontsshi, &
 563 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 564 !        write(2,*) "After grad_shield_side"
 565 !        call flush(iout)
 566 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 567 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 568 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 569 !        ivec_displ(0)*3*maxcontsshi, &
 570 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 571 !        write(2,*) "After MPI_SHI"
 572 !        call flush(iout)
 573         iii=0
 574         jjj=0
 575         do i=1,nres
 576          fac_shield(i)=fac_shieldbuf(i)
 577          ishield_list(i)=ishield_listbuf(i)
 578 !         write(iout,*) i,fac_shield(i)
 579          do j=1,3
 580          iii=iii+1
 581          grad_shield(j,i)=grad_shieldbuf2(iii)
 582          enddo !j
 583          do j=1,ishield_list(i)
 584 !          write (iout,*) "ishild", ishield_list(i),i
 585            shield_list(j,i)=shield_listbuf(j,i)
 586           enddo
 587           do j=1,maxcontsshi
 588           do k=1,3
 589            jjj=jjj+1
 590           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 591           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 592           enddo !k
 593         enddo !j
 594        enddo !i
 595        endif
 596 #ifdef DEBUG
 597        write(iout,*) "after reduce fac_shield reduce"
 598        do i=1,nres
 599         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 600         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 601         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 602        enddo
 603 #endif
 604 #undef DEBUG
 605        endif
 606
 607
 608
 609 !       print *,"AFTER EGB",ipot,evdw
 610 !mc
 611 !mc Sep-06: egb takes care of dynamic ss bonds too
 612 !mc
 613 !      if (dyn_ss) call dyn_set_nss
 614 !      print *,"Processor",myrank," computed USCSC"
 615 #ifdef TIMING
 616       time01=MPI_Wtime()
 617 #endif
 618       call vec_and_deriv
 619 #ifdef TIMING
 620       time_vec=time_vec+MPI_Wtime()-time01
 621 #endif
 622
 623
 624
 625
 626 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 627       if (ipot.lt.6) then
 628 #ifdef SPLITELE
 629 !         print *,"after ipot if", ipot
 630          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 631              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 632              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 633              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 634 #else
 635          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 636              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 637              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 638              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 639 #endif
 640 !            print *,"just befor eelec call"
 641             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 642 !            print *, "ELEC calc"
 643          else
 644             ees=0.0d0
 645             evdw1=0.0d0
 646             eel_loc=0.0d0
 647             eello_turn3=0.0d0
 648             eello_turn4=0.0d0
 649          endif
 650       else
 651 !        write (iout,*) "Soft-spheer ELEC potential"
 652         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 653          eello_turn4)
 654       endif
 655 !      print *,"Processor",myrank," computed UELEC"
 656 !
 657 ! Calculate excluded-volume interaction energy between peptide groups
 658 ! and side chains.
 659 !
 660 !       write(iout,*) "in etotal calc exc;luded",ipot
 661
 662       if (ipot.lt.6) then
 663        if(wscp.gt.0d0) then
 664         call escp(evdw2,evdw2_14)
 665        else
 666         evdw2=0
 667         evdw2_14=0
 668        endif
 669       else
 670 !        write (iout,*) "Soft-sphere SCP potential"
 671         call escp_soft_sphere(evdw2,evdw2_14)
 672       endif
 673 !        write(iout,*) "in etotal before ebond",ipot
 674
 675 !
 676 ! Calculate the bond-stretching energy
 677 !
 678       call ebond(estr)
 679 !       print *,"EBOND",estr
 680 !       write(iout,*) "in etotal afer ebond",ipot
 681
 682 !
 683 ! Calculate the disulfide-bridge and other energy and the contributions
 684 ! from other distance constraints.
 685 !      print *,'Calling EHPB'
 686       call edis(ehpb)
 687 !elwrite(iout,*) "in etotal afer edis",ipot
 688 !      print *,'EHPB exitted succesfully.'
 689 !
 690 ! Calculate the virtual-bond-angle energy.
 691 !       write(iout,*) "in etotal afer edis",ipot
 692
 693 !      if (wang.gt.0.0d0) then
 694 !        call ebend(ebe,ethetacnstr)
 695 !      else
 696 !        ebe=0
 697 !        ethetacnstr=0
 698 !      endif
 699       if (wang.gt.0d0) then
 700        if (tor_mode.eq.0) then
 701          call ebend(ebe)
 702        else
 703 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 704 !C energy function
 705          call ebend_kcc(ebe)
 706        endif
 707       else
 708         ebe=0.0d0
 709       endif
 710       ethetacnstr=0.0d0
 711       if (with_theta_constr) call etheta_constr(ethetacnstr)
 712
 713 !       write(iout,*) "in etotal afer ebe",ipot
 714
 715 !      print *,"Processor",myrank," computed UB"
 716 !
 717 ! Calculate the SC local energy.
 718 !
 719       call esc(escloc)
 720 !elwrite(iout,*) "in etotal afer esc",ipot
 721 !      print *,"Processor",myrank," computed USC"
 722 !
 723 ! Calculate the virtual-bond torsional energy.
 724 !
 725 !d    print *,'nterm=',nterm
 726 !      if (wtor.gt.0) then
 727 !       call etor(etors,edihcnstr)
 728 !      else
 729 !       etors=0
 730 !       edihcnstr=0
 731 !      endif
 732       if (wtor.gt.0.0d0) then
 733          if (tor_mode.eq.0) then
 734            call etor(etors)
 735          else
 736 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 737 !C energy function
 738            call etor_kcc(etors)
 739          endif
 740       else
 741         etors=0.0d0
 742       endif
 743       edihcnstr=0.0d0
 744       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 745 !c      print *,"Processor",myrank," computed Utor"
 746
 747 !      print *,"Processor",myrank," computed Utor"
 748
 749 !
 750 ! 6/23/01 Calculate double-torsional energy
 751 !
 752 !elwrite(iout,*) "in etotal",ipot
 753       if (wtor_d.gt.0) then
 754        call etor_d(etors_d)
 755       else
 756        etors_d=0
 757       endif
 758 !      print *,"Processor",myrank," computed Utord"
 759 !
 760 ! 21/5/07 Calculate local sicdechain correlation energy
 761 !
 762       if (wsccor.gt.0.0d0) then
 763         call eback_sc_corr(esccor)
 764       else
 765         esccor=0.0d0
 766       endif
 767
 768 !      write(iout,*) "before multibody"
 769       call flush(iout)
 770 !      print *,"Processor",myrank," computed Usccorr"
 771 !
 772 ! 12/1/95 Multi-body terms
 773 !
 774       n_corr=0
 775       n_corr1=0
 776       call flush(iout)
 777       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 778           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 779          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 780 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 781 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 782       else
 783          ecorr=0.0d0
 784          ecorr5=0.0d0
 785          ecorr6=0.0d0
 786          eturn6=0.0d0
 787       endif
 788 !elwrite(iout,*) "in etotal",ipot
 789       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 790          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 791 !d         write (iout,*) "multibody_hb ecorr",ecorr
 792       endif
 793 !      write(iout,*) "afeter  multibody hb"
 794
 795 !      print *,"Processor",myrank," computed Ucorr"
 796 !
 797 ! If performing constraint dynamics, call the constraint energy
 798 !  after the equilibration time
 799       if(usampl.and.totT.gt.eq_time) then
 800 !elwrite(iout,*) "afeter  multibody hb"
 801          call EconstrQ
 802 !elwrite(iout,*) "afeter  multibody hb"
 803          call Econstr_back
 804 !elwrite(iout,*) "afeter  multibody hb"
 805       else
 806          Uconst=0.0d0
 807          Uconst_back=0.0d0
 808       endif
 809       call flush(iout)
 810 !         write(iout,*) "after Econstr"
 811
 812       if (wliptran.gt.0) then
 813 !        print *,"PRZED WYWOLANIEM"
 814         call Eliptransfer(eliptran)
 815       else
 816        eliptran=0.0d0
 817       endif
 818       if (fg_rank.eq.0) then
 819       if (AFMlog.gt.0) then
 820         call AFMforce(Eafmforce)
 821       else if (selfguide.gt.0) then
 822         call AFMvel(Eafmforce)
 823       else
 824         Eafmforce=0.0d0
 825       endif
 826       endif
 827       if (tubemode.eq.1) then
 828        call calctube(etube)
 829       else if (tubemode.eq.2) then
 830        call calctube2(etube)
 831       elseif (tubemode.eq.3) then
 832        call calcnano(etube)
 833       else
 834        etube=0.0d0
 835       endif
 836 !--------------------------------------------------------
 837 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 838 !      print *,"before",ees,evdw1,ecorr
 839 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 840       if (nres_molec(2).gt.0) then
 841       call ebond_nucl(estr_nucl)
 842       call ebend_nucl(ebe_nucl)
 843       call etor_nucl(etors_nucl)
 844       call esb_gb(evdwsb,eelsb)
 845       call epp_nucl_sub(evdwpp,eespp)
 846       call epsb(evdwpsb,eelpsb)
 847       call esb(esbloc)
 848       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 849             call ecat_nucl(ecation_nucl)
 850       else
 851        etors_nucl=0.0d0
 852        estr_nucl=0.0d0
 853        ecorr3_nucl=0.0d0
 854        ecorr_nucl=0.0d0
 855        ebe_nucl=0.0d0
 856        evdwsb=0.0d0
 857        eelsb=0.0d0
 858        esbloc=0.0d0
 859        evdwpsb=0.0d0
 860        eelpsb=0.0d0
 861        evdwpp=0.0d0
 862        eespp=0.0d0
 863        etors_d_nucl=0.0d0
 864        ecation_nucl=0.0d0
 865       endif
 866 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 867 !      print *,"before ecatcat",wcatcat
 868       if (nres_molec(5).gt.0) then
 869       if (nfgtasks.gt.1) then
 870       if (fg_rank.eq.0) then
 871       call ecatcat(ecationcation)
 872       endif
 873       else
 874       call ecatcat(ecationcation)
 875       endif
 876       if (oldion.gt.0) then
 877       call ecat_prot(ecation_prot)
 878       else
 879       call ecats_prot_amber(ecation_prot)
 880       endif
 881       else
 882       ecationcation=0.0d0
 883       ecation_prot=0.0d0
 884       endif
 885       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 886       call eprot_sc_base(escbase)
 887       call epep_sc_base(epepbase)
 888       call eprot_sc_phosphate(escpho)
 889       call eprot_pep_phosphate(epeppho)
 890       else
 891       epepbase=0.0
 892       escbase=0.0
 893       escpho=0.0
 894       epeppho=0.0
 895       endif
 896 !      call ecatcat(ecationcation)
 897 !      print *,"after ebend", wtor_nucl
 898 #ifdef TIMING
 899       time_enecalc=time_enecalc+MPI_Wtime()-time00
 900 #endif
 901 !      print *,"Processor",myrank," computed Uconstr"
 902 #ifdef TIMING
 903       time00=MPI_Wtime()
 904 #endif
 905 !
 906 ! Sum the energies
 907 !
 908       energia(1)=evdw
 909 #ifdef SCP14
 910       energia(2)=evdw2-evdw2_14
 911       energia(18)=evdw2_14
 912 #else
 913       energia(2)=evdw2
 914       energia(18)=0.0d0
 915 #endif
 916 #ifdef SPLITELE
 917       energia(3)=ees
 918       energia(16)=evdw1
 919 #else
 920       energia(3)=ees+evdw1
 921       energia(16)=0.0d0
 922 #endif
 923       energia(4)=ecorr
 924       energia(5)=ecorr5
 925       energia(6)=ecorr6
 926       energia(7)=eel_loc
 927       energia(8)=eello_turn3
 928       energia(9)=eello_turn4
 929       energia(10)=eturn6
 930       energia(11)=ebe
 931       energia(12)=escloc
 932       energia(13)=etors
 933       energia(14)=etors_d
 934       energia(15)=ehpb
 935       energia(19)=edihcnstr
 936       energia(17)=estr
 937       energia(20)=Uconst+Uconst_back
 938       energia(21)=esccor
 939       energia(22)=eliptran
 940       energia(23)=Eafmforce
 941       energia(24)=ethetacnstr
 942       energia(25)=etube
 943 !---------------------------------------------------------------
 944       energia(26)=evdwpp
 945       energia(27)=eespp
 946       energia(28)=evdwpsb
 947       energia(29)=eelpsb
 948       energia(30)=evdwsb
 949       energia(31)=eelsb
 950       energia(32)=estr_nucl
 951       energia(33)=ebe_nucl
 952       energia(34)=esbloc
 953       energia(35)=etors_nucl
 954       energia(36)=etors_d_nucl
 955       energia(37)=ecorr_nucl
 956       energia(38)=ecorr3_nucl
 957 !----------------------------------------------------------------------
 958 !    Here are the energies showed per procesor if the are more processors
 959 !    per molecule then we sum it up in sum_energy subroutine
 960 !      print *," Processor",myrank," calls SUM_ENERGY"
 961       energia(42)=ecation_prot
 962       energia(41)=ecationcation
 963       energia(46)=escbase
 964       energia(47)=epepbase
 965       energia(48)=escpho
 966       energia(49)=epeppho
 967 !      energia(50)=ecations_prot_amber
 968       energia(50)=ecation_nucl
 969       call sum_energy(energia,.true.)
 970       if (dyn_ss) call dyn_set_nss
 971 !      print *," Processor",myrank," left SUM_ENERGY"
 972 #ifdef TIMING
 973       time_sumene=time_sumene+MPI_Wtime()-time00
 974 #endif
 975 !        call enerprint(energia)
 976 !elwrite(iout,*)"finish etotal"
 977       return
 978       end subroutine etotal
 979 !-----------------------------------------------------------------------------
 980       subroutine sum_energy(energia,reduce)
 981 !      implicit real*8 (a-h,o-z)
 982 !      include 'DIMENSIONS'
 983 #ifndef ISNAN
 984       external proc_proc
 985 #ifdef WINPGI
 986 !MS$ATTRIBUTES C ::  proc_proc
 987 #endif
 988 #endif
 989 #ifdef MPI
 990       include "mpif.h"
 991 #endif
 992 !      include 'COMMON.SETUP'
 993 !      include 'COMMON.IOUNITS'
 994       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 995 !      include 'COMMON.FFIELD'
 996 !      include 'COMMON.DERIV'
 997 !      include 'COMMON.INTERACT'
 998 !      include 'COMMON.SBRIDGE'
 999 !      include 'COMMON.CHAIN'
1000 !      include 'COMMON.VAR'
1001 !      include 'COMMON.CONTROL'
1002 !      include 'COMMON.TIME1'
1003       logical :: reduce
1004       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1005       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1006       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1007         eliptran,etube, Eafmforce,ethetacnstr
1008       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1009                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1010                       ecorr3_nucl
1011       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1012                       ecation_nucl
1013       real(kind=8) :: escbase,epepbase,escpho,epeppho
1014       integer :: i
1015 #ifdef MPI
1016       integer :: ierr
1017       real(kind=8) :: time00
1018       if (nfgtasks.gt.1 .and. reduce) then
1019
1020 #ifdef DEBUG
1021         write (iout,*) "energies before REDUCE"
1022         call enerprint(energia)
1023         call flush(iout)
1024 #endif
1025         do i=0,n_ene
1026           enebuff(i)=energia(i)
1027         enddo
1028         time00=MPI_Wtime()
1029         call MPI_Barrier(FG_COMM,IERR)
1030         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1031         time00=MPI_Wtime()
1032         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1033           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1034 #ifdef DEBUG
1035         write (iout,*) "energies after REDUCE"
1036         call enerprint(energia)
1037         call flush(iout)
1038 #endif
1039         time_Reduce=time_Reduce+MPI_Wtime()-time00
1040       endif
1041       if (fg_rank.eq.0) then
1042 #endif
1043       evdw=energia(1)
1044 #ifdef SCP14
1045       evdw2=energia(2)+energia(18)
1046       evdw2_14=energia(18)
1047 #else
1048       evdw2=energia(2)
1049 #endif
1050 #ifdef SPLITELE
1051       ees=energia(3)
1052       evdw1=energia(16)
1053 #else
1054       ees=energia(3)
1055       evdw1=0.0d0
1056 #endif
1057       ecorr=energia(4)
1058       ecorr5=energia(5)
1059       ecorr6=energia(6)
1060       eel_loc=energia(7)
1061       eello_turn3=energia(8)
1062       eello_turn4=energia(9)
1063       eturn6=energia(10)
1064       ebe=energia(11)
1065       escloc=energia(12)
1066       etors=energia(13)
1067       etors_d=energia(14)
1068       ehpb=energia(15)
1069       edihcnstr=energia(19)
1070       estr=energia(17)
1071       Uconst=energia(20)
1072       esccor=energia(21)
1073       eliptran=energia(22)
1074       Eafmforce=energia(23)
1075       ethetacnstr=energia(24)
1076       etube=energia(25)
1077       evdwpp=energia(26)
1078       eespp=energia(27)
1079       evdwpsb=energia(28)
1080       eelpsb=energia(29)
1081       evdwsb=energia(30)
1082       eelsb=energia(31)
1083       estr_nucl=energia(32)
1084       ebe_nucl=energia(33)
1085       esbloc=energia(34)
1086       etors_nucl=energia(35)
1087       etors_d_nucl=energia(36)
1088       ecorr_nucl=energia(37)
1089       ecorr3_nucl=energia(38)
1090       ecation_prot=energia(42)
1091       ecationcation=energia(41)
1092       escbase=energia(46)
1093       epepbase=energia(47)
1094       escpho=energia(48)
1095       epeppho=energia(49)
1096       ecation_nucl=energia(50)
1097 !      ecations_prot_amber=energia(50)
1098
1099 !      energia(41)=ecation_prot
1100 !      energia(42)=ecationcation
1101
1102
1103 #ifdef SPLITELE
1104       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*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+wcatnucl*ecation_nucl
1117 #else
1118       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1119        +wang*ebe+wtor*etors+wscloc*escloc &
1120        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1121        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1122        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1123        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1124        +Eafmforce+ethetacnstr &
1125        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1126        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1127        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1128        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1129        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1130        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1131 #endif
1132       energia(0)=etot
1133 ! detecting NaNQ
1134 #ifdef ISNAN
1135 #ifdef AIX
1136       if (isnan(etot).ne.0) energia(0)=1.0d+99
1137 #else
1138       if (isnan(etot)) energia(0)=1.0d+99
1139 #endif
1140 #else
1141       i=0
1142 #ifdef WINPGI
1143       idumm=proc_proc(etot,i)
1144 #else
1145       call proc_proc(etot,i)
1146 #endif
1147       if(i.eq.1)energia(0)=1.0d+99
1148 #endif
1149 #ifdef MPI
1150       endif
1151 #endif
1152 !      call enerprint(energia)
1153       call flush(iout)
1154       return
1155       end subroutine sum_energy
1156 !-----------------------------------------------------------------------------
1157       subroutine rescale_weights(t_bath)
1158 !      implicit real*8 (a-h,o-z)
1159 #ifdef MPI
1160       include 'mpif.h'
1161 #endif
1162 !      include 'DIMENSIONS'
1163 !      include 'COMMON.IOUNITS'
1164 !      include 'COMMON.FFIELD'
1165 !      include 'COMMON.SBRIDGE'
1166       real(kind=8) :: kfac=2.4d0
1167       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1168 !el local variables
1169       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1170       real(kind=8) :: T0=3.0d2
1171       integer :: ierror
1172 !      facT=temp0/t_bath
1173 !      facT=2*temp0/(t_bath+temp0)
1174       if (rescale_mode.eq.0) then
1175         facT(1)=1.0d0
1176         facT(2)=1.0d0
1177         facT(3)=1.0d0
1178         facT(4)=1.0d0
1179         facT(5)=1.0d0
1180         facT(6)=1.0d0
1181       else if (rescale_mode.eq.1) then
1182         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1183         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1184         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1185         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1186         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1187 #ifdef WHAM_RUN
1188 !#if defined(WHAM_RUN) || defined(CLUSTER)
1189 #if defined(FUNCTH)
1190 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1191         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1192 #elif defined(FUNCT)
1193         facT(6)=t_bath/T0
1194 #else
1195         facT(6)=1.0d0
1196 #endif
1197 #endif
1198       else if (rescale_mode.eq.2) then
1199         x=t_bath/temp0
1200         x2=x*x
1201         x3=x2*x
1202         x4=x3*x
1203         x5=x4*x
1204         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1205         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1206         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1207         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1208         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1209 #ifdef WHAM_RUN
1210 !#if defined(WHAM_RUN) || defined(CLUSTER)
1211 #if defined(FUNCTH)
1212         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1213 #elif defined(FUNCT)
1214         facT(6)=t_bath/T0
1215 #else
1216         facT(6)=1.0d0
1217 #endif
1218 #endif
1219       else
1220         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1221         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1222 #ifdef MPI
1223        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1224 #endif
1225        stop 555
1226       endif
1227       welec=weights(3)*fact(1)
1228       wcorr=weights(4)*fact(3)
1229       wcorr5=weights(5)*fact(4)
1230       wcorr6=weights(6)*fact(5)
1231       wel_loc=weights(7)*fact(2)
1232       wturn3=weights(8)*fact(2)
1233       wturn4=weights(9)*fact(3)
1234       wturn6=weights(10)*fact(5)
1235       wtor=weights(13)*fact(1)
1236       wtor_d=weights(14)*fact(2)
1237       wsccor=weights(21)*fact(1)
1238       welpsb=weights(28)*fact(1)
1239       wcorr_nucl= weights(37)*fact(1)
1240       wcorr3_nucl=weights(38)*fact(2)
1241       wtor_nucl=  weights(35)*fact(1)
1242       wtor_d_nucl=weights(36)*fact(2)
1243       wpepbase=weights(47)*fact(1)
1244       return
1245       end subroutine rescale_weights
1246 !-----------------------------------------------------------------------------
1247       subroutine enerprint(energia)
1248 !      implicit real*8 (a-h,o-z)
1249 !      include 'DIMENSIONS'
1250 !      include 'COMMON.IOUNITS'
1251 !      include 'COMMON.FFIELD'
1252 !      include 'COMMON.SBRIDGE'
1253 !      include 'COMMON.MD'
1254       real(kind=8) :: energia(0:n_ene)
1255 !el local variables
1256       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1257       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1258       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1259        etube,ethetacnstr,Eafmforce
1260       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1261                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1262                       ecorr3_nucl
1263       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1264                       ecation_nucl
1265       real(kind=8) :: escbase,epepbase,escpho,epeppho
1266
1267       etot=energia(0)
1268       evdw=energia(1)
1269       evdw2=energia(2)
1270 #ifdef SCP14
1271       evdw2=energia(2)+energia(18)
1272 #else
1273       evdw2=energia(2)
1274 #endif
1275       ees=energia(3)
1276 #ifdef SPLITELE
1277       evdw1=energia(16)
1278 #endif
1279       ecorr=energia(4)
1280       ecorr5=energia(5)
1281       ecorr6=energia(6)
1282       eel_loc=energia(7)
1283       eello_turn3=energia(8)
1284       eello_turn4=energia(9)
1285       eello_turn6=energia(10)
1286       ebe=energia(11)
1287       escloc=energia(12)
1288       etors=energia(13)
1289       etors_d=energia(14)
1290       ehpb=energia(15)
1291       edihcnstr=energia(19)
1292       estr=energia(17)
1293       Uconst=energia(20)
1294       esccor=energia(21)
1295       eliptran=energia(22)
1296       Eafmforce=energia(23)
1297       ethetacnstr=energia(24)
1298       etube=energia(25)
1299       evdwpp=energia(26)
1300       eespp=energia(27)
1301       evdwpsb=energia(28)
1302       eelpsb=energia(29)
1303       evdwsb=energia(30)
1304       eelsb=energia(31)
1305       estr_nucl=energia(32)
1306       ebe_nucl=energia(33)
1307       esbloc=energia(34)
1308       etors_nucl=energia(35)
1309       etors_d_nucl=energia(36)
1310       ecorr_nucl=energia(37)
1311       ecorr3_nucl=energia(38)
1312       ecation_prot=energia(42)
1313       ecationcation=energia(41)
1314       escbase=energia(46)
1315       epepbase=energia(47)
1316       escpho=energia(48)
1317       epeppho=energia(49)
1318       ecation_nucl=energia(50)
1319 !      ecations_prot_amber=energia(50)
1320 #ifdef SPLITELE
1321       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1322         estr,wbond,ebe,wang,&
1323         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1324         ecorr,wcorr,&
1325         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1326         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1327         edihcnstr,ethetacnstr,ebr*nss,&
1328         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1329         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1330         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1331         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1332         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1333         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1334         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1335         ecation_nucl,wcatnucl,etot
1336    10 format (/'Virtual-chain energies:'// &
1337        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1338        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1339        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1340        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1341        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1342        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1343        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1344        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1345        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1346        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1347        ' (SS bridges & dist. cnstr.)'/ &
1348        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1349        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1350        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1351        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1352        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1353        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1354        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1355        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1356        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1357        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1358        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1359        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1360        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1361        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1362        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1363        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1364        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1365        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1366        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1367        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1368        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1369        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1370        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1371        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1372        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1373        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1374        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1375        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1376        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1377        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1378        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1379        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1380        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1381        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1382        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1383        'ETOT=  ',1pE16.6,' (total)')
1384 #else
1385       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1386         estr,wbond,ebe,wang,&
1387         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1388         ecorr,wcorr,&
1389         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1390         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1391         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1392         etube,wtube, &
1393         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1394         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1395         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1396         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1397         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1398         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1399         ecation_nucl,wcatnucl,etot
1400    10 format (/'Virtual-chain energies:'// &
1401        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1402        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1403        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1404        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1405        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1406        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1407        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1408        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1409        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1410        ' (SS bridges & dist. cnstr.)'/ &
1411        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1412        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1413        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1414        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1415        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1416        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1417        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1418        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1419        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1420        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1421        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1422        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1423        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1424        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1425        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1426        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1427        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1428        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1429        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1430        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1431        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1432        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1433        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1434        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1435        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1436        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1437        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1438        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1439        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1440        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1441        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1442        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1443        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1444        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1445        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1446        'ETOT=  ',1pE16.6,' (total)')
1447 #endif
1448       return
1449       end subroutine enerprint
1450 !-----------------------------------------------------------------------------
1451       subroutine elj(evdw)
1452 !
1453 ! This subroutine calculates the interaction energy of nonbonded side chains
1454 ! assuming the LJ potential of interaction.
1455 !
1456 !      implicit real*8 (a-h,o-z)
1457 !      include 'DIMENSIONS'
1458       real(kind=8),parameter :: accur=1.0d-10
1459 !      include 'COMMON.GEO'
1460 !      include 'COMMON.VAR'
1461 !      include 'COMMON.LOCAL'
1462 !      include 'COMMON.CHAIN'
1463 !      include 'COMMON.DERIV'
1464 !      include 'COMMON.INTERACT'
1465 !      include 'COMMON.TORSION'
1466 !      include 'COMMON.SBRIDGE'
1467 !      include 'COMMON.NAMES'
1468 !      include 'COMMON.IOUNITS'
1469 !      include 'COMMON.CONTACTS'
1470       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1471       integer :: num_conti
1472 !el local variables
1473       integer :: i,itypi,iint,j,itypi1,itypj,k
1474       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1475        aa,bb,sslipj,ssgradlipj
1476       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1477       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1478
1479 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1480       evdw=0.0D0
1481 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1482 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1483 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1484 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1485
1486       do i=iatsc_s,iatsc_e
1487         itypi=iabs(itype(i,1))
1488         if (itypi.eq.ntyp1) cycle
1489         itypi1=iabs(itype(i+1,1))
1490         xi=c(1,nres+i)
1491         yi=c(2,nres+i)
1492         zi=c(3,nres+i)
1493         call to_box(xi,yi,zi)
1494         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1495
1496 ! Change 12/1/95
1497         num_conti=0
1498 !
1499 ! Calculate SC interaction energy.
1500 !
1501         do iint=1,nint_gr(i)
1502 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1503 !d   &                  'iend=',iend(i,iint)
1504           do j=istart(i,iint),iend(i,iint)
1505             itypj=iabs(itype(j,1))
1506             if (itypj.eq.ntyp1) cycle
1507             xj=c(1,nres+j)-xi
1508             yj=c(2,nres+j)-yi
1509             zj=c(3,nres+j)-zi
1510             call to_box(xj,yj,zj)
1511             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1512             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1513              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1514             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1515              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1516             xj=boxshift(xj-xi,boxxsize)
1517             yj=boxshift(yj-yi,boxysize)
1518             zj=boxshift(zj-zi,boxzsize)
1519 ! Change 12/1/95 to calculate four-body interactions
1520             rij=xj*xj+yj*yj+zj*zj
1521             rrij=1.0D0/rij
1522 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1523             eps0ij=eps(itypi,itypj)
1524             fac=rrij**expon2
1525             e1=fac*fac*aa_aq(itypi,itypj)
1526             e2=fac*bb_aq(itypi,itypj)
1527             evdwij=e1+e2
1528 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1529 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1530 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1531 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1532 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1533 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1534             evdw=evdw+evdwij
1535 !
1536 ! Calculate the components of the gradient in DC and X
1537 !
1538             fac=-rrij*(e1+evdwij)
1539             gg(1)=xj*fac
1540             gg(2)=yj*fac
1541             gg(3)=zj*fac
1542             do k=1,3
1543               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1544               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1545               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1546               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1547             enddo
1548 !grad            do k=i,j-1
1549 !grad              do l=1,3
1550 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1551 !grad              enddo
1552 !grad            enddo
1553 !
1554 ! 12/1/95, revised on 5/20/97
1555 !
1556 ! Calculate the contact function. The ith column of the array JCONT will
1557 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1558 ! greater than I). The arrays FACONT and GACONT will contain the values of
1559 ! the contact function and its derivative.
1560 !
1561 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1562 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1563 ! Uncomment next line, if the correlation interactions are contact function only
1564             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1565               rij=dsqrt(rij)
1566               sigij=sigma(itypi,itypj)
1567               r0ij=rs0(itypi,itypj)
1568 !
1569 ! Check whether the SC's are not too far to make a contact.
1570 !
1571               rcut=1.5d0*r0ij
1572               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1573 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1574 !
1575               if (fcont.gt.0.0D0) then
1576 ! If the SC-SC distance if close to sigma, apply spline.
1577 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1578 !Adam &             fcont1,fprimcont1)
1579 !Adam           fcont1=1.0d0-fcont1
1580 !Adam           if (fcont1.gt.0.0d0) then
1581 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1582 !Adam             fcont=fcont*fcont1
1583 !Adam           endif
1584 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1585 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1586 !ga             do k=1,3
1587 !ga               gg(k)=gg(k)*eps0ij
1588 !ga             enddo
1589 !ga             eps0ij=-evdwij*eps0ij
1590 ! Uncomment for AL's type of SC correlation interactions.
1591 !adam           eps0ij=-evdwij
1592                 num_conti=num_conti+1
1593                 jcont(num_conti,i)=j
1594                 facont(num_conti,i)=fcont*eps0ij
1595                 fprimcont=eps0ij*fprimcont/rij
1596                 fcont=expon*fcont
1597 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1598 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1599 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1600 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1601                 gacont(1,num_conti,i)=-fprimcont*xj
1602                 gacont(2,num_conti,i)=-fprimcont*yj
1603                 gacont(3,num_conti,i)=-fprimcont*zj
1604 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1605 !d              write (iout,'(2i3,3f10.5)')
1606 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1607               endif
1608             endif
1609           enddo      ! j
1610         enddo        ! iint
1611 ! Change 12/1/95
1612         num_cont(i)=num_conti
1613       enddo          ! i
1614       do i=1,nct
1615         do j=1,3
1616           gvdwc(j,i)=expon*gvdwc(j,i)
1617           gvdwx(j,i)=expon*gvdwx(j,i)
1618         enddo
1619       enddo
1620 !******************************************************************************
1621 !
1622 !                              N O T E !!!
1623 !
1624 ! To save time, the factor of EXPON has been extracted from ALL components
1625 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1626 ! use!
1627 !
1628 !******************************************************************************
1629       return
1630       end subroutine elj
1631 !-----------------------------------------------------------------------------
1632       subroutine eljk(evdw)
1633 !
1634 ! This subroutine calculates the interaction energy of nonbonded side chains
1635 ! assuming the LJK potential of interaction.
1636 !
1637 !      implicit real*8 (a-h,o-z)
1638 !      include 'DIMENSIONS'
1639 !      include 'COMMON.GEO'
1640 !      include 'COMMON.VAR'
1641 !      include 'COMMON.LOCAL'
1642 !      include 'COMMON.CHAIN'
1643 !      include 'COMMON.DERIV'
1644 !      include 'COMMON.INTERACT'
1645 !      include 'COMMON.IOUNITS'
1646 !      include 'COMMON.NAMES'
1647       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1648       logical :: scheck
1649 !el local variables
1650       integer :: i,iint,j,itypi,itypi1,k,itypj
1651       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1652          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1653       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1654
1655 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1656       evdw=0.0D0
1657       do i=iatsc_s,iatsc_e
1658         itypi=iabs(itype(i,1))
1659         if (itypi.eq.ntyp1) cycle
1660         itypi1=iabs(itype(i+1,1))
1661         xi=c(1,nres+i)
1662         yi=c(2,nres+i)
1663         zi=c(3,nres+i)
1664         call to_box(xi,yi,zi)
1665         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1666
1667 !
1668 ! Calculate SC interaction energy.
1669 !
1670         do iint=1,nint_gr(i)
1671           do j=istart(i,iint),iend(i,iint)
1672             itypj=iabs(itype(j,1))
1673             if (itypj.eq.ntyp1) cycle
1674             xj=c(1,nres+j)-xi
1675             yj=c(2,nres+j)-yi
1676             zj=c(3,nres+j)-zi
1677             call to_box(xj,yj,zj)
1678             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1679             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1680              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1681             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1682              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1683             xj=boxshift(xj-xi,boxxsize)
1684             yj=boxshift(yj-yi,boxysize)
1685             zj=boxshift(zj-zi,boxzsize)
1686             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1687             fac_augm=rrij**expon
1688             e_augm=augm(itypi,itypj)*fac_augm
1689             r_inv_ij=dsqrt(rrij)
1690             rij=1.0D0/r_inv_ij
1691             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1692             fac=r_shift_inv**expon
1693             e1=fac*fac*aa_aq(itypi,itypj)
1694             e2=fac*bb_aq(itypi,itypj)
1695             evdwij=e_augm+e1+e2
1696 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1697 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1698 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1699 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1700 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1701 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1702 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1703             evdw=evdw+evdwij
1704 !
1705 ! Calculate the components of the gradient in DC and X
1706 !
1707             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1708             gg(1)=xj*fac
1709             gg(2)=yj*fac
1710             gg(3)=zj*fac
1711             do k=1,3
1712               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1713               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1714               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1715               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1716             enddo
1717 !grad            do k=i,j-1
1718 !grad              do l=1,3
1719 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1720 !grad              enddo
1721 !grad            enddo
1722           enddo      ! j
1723         enddo        ! iint
1724       enddo          ! i
1725       do i=1,nct
1726         do j=1,3
1727           gvdwc(j,i)=expon*gvdwc(j,i)
1728           gvdwx(j,i)=expon*gvdwx(j,i)
1729         enddo
1730       enddo
1731       return
1732       end subroutine eljk
1733 !-----------------------------------------------------------------------------
1734       subroutine ebp(evdw)
1735 !
1736 ! This subroutine calculates the interaction energy of nonbonded side chains
1737 ! assuming the Berne-Pechukas potential of interaction.
1738 !
1739       use comm_srutu
1740       use calc_data
1741 !      implicit real*8 (a-h,o-z)
1742 !      include 'DIMENSIONS'
1743 !      include 'COMMON.GEO'
1744 !      include 'COMMON.VAR'
1745 !      include 'COMMON.LOCAL'
1746 !      include 'COMMON.CHAIN'
1747 !      include 'COMMON.DERIV'
1748 !      include 'COMMON.NAMES'
1749 !      include 'COMMON.INTERACT'
1750 !      include 'COMMON.IOUNITS'
1751 !      include 'COMMON.CALC'
1752       use comm_srutu
1753 !el      integer :: icall
1754 !el      common /srutu/ icall
1755 !     double precision rrsave(maxdim)
1756       logical :: lprn
1757 !el local variables
1758       integer :: iint,itypi,itypi1,itypj
1759       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1760         ssgradlipj, aa, bb
1761       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1762
1763 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1764       evdw=0.0D0
1765 !     if (icall.eq.0) then
1766 !       lprn=.true.
1767 !     else
1768         lprn=.false.
1769 !     endif
1770 !el      ind=0
1771       do i=iatsc_s,iatsc_e
1772         itypi=iabs(itype(i,1))
1773         if (itypi.eq.ntyp1) cycle
1774         itypi1=iabs(itype(i+1,1))
1775         xi=c(1,nres+i)
1776         yi=c(2,nres+i)
1777         zi=c(3,nres+i)
1778         call to_box(xi,yi,zi)
1779         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1780         dxi=dc_norm(1,nres+i)
1781         dyi=dc_norm(2,nres+i)
1782         dzi=dc_norm(3,nres+i)
1783 !        dsci_inv=dsc_inv(itypi)
1784         dsci_inv=vbld_inv(i+nres)
1785 !
1786 ! Calculate SC interaction energy.
1787 !
1788         do iint=1,nint_gr(i)
1789           do j=istart(i,iint),iend(i,iint)
1790 !el            ind=ind+1
1791             itypj=iabs(itype(j,1))
1792             if (itypj.eq.ntyp1) cycle
1793 !            dscj_inv=dsc_inv(itypj)
1794             dscj_inv=vbld_inv(j+nres)
1795             chi1=chi(itypi,itypj)
1796             chi2=chi(itypj,itypi)
1797             chi12=chi1*chi2
1798             chip1=chip(itypi)
1799             chip2=chip(itypj)
1800             chip12=chip1*chip2
1801             alf1=alp(itypi)
1802             alf2=alp(itypj)
1803             alf12=0.5D0*(alf1+alf2)
1804 ! For diagnostics only!!!
1805 !           chi1=0.0D0
1806 !           chi2=0.0D0
1807 !           chi12=0.0D0
1808 !           chip1=0.0D0
1809 !           chip2=0.0D0
1810 !           chip12=0.0D0
1811 !           alf1=0.0D0
1812 !           alf2=0.0D0
1813 !           alf12=0.0D0
1814             xj=c(1,nres+j)-xi
1815             yj=c(2,nres+j)-yi
1816             zj=c(3,nres+j)-zi
1817             call to_box(xj,yj,zj)
1818             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1819             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1820              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1821             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1822              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1823             xj=boxshift(xj-xi,boxxsize)
1824             yj=boxshift(yj-yi,boxysize)
1825             zj=boxshift(zj-zi,boxzsize)
1826             dxj=dc_norm(1,nres+j)
1827             dyj=dc_norm(2,nres+j)
1828             dzj=dc_norm(3,nres+j)
1829             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1830 !d          if (icall.eq.0) then
1831 !d            rrsave(ind)=rrij
1832 !d          else
1833 !d            rrij=rrsave(ind)
1834 !d          endif
1835             rij=dsqrt(rrij)
1836 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1837             call sc_angular
1838 ! Calculate whole angle-dependent part of epsilon and contributions
1839 ! to its derivatives
1840             fac=(rrij*sigsq)**expon2
1841             e1=fac*fac*aa_aq(itypi,itypj)
1842             e2=fac*bb_aq(itypi,itypj)
1843             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1844             eps2der=evdwij*eps3rt
1845             eps3der=evdwij*eps2rt
1846             evdwij=evdwij*eps2rt*eps3rt
1847             evdw=evdw+evdwij
1848             if (lprn) then
1849             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1850             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1851 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1852 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1853 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1854 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1855 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1856 !d     &        evdwij
1857             endif
1858 ! Calculate gradient components.
1859             e1=e1*eps1*eps2rt**2*eps3rt**2
1860             fac=-expon*(e1+evdwij)
1861             sigder=fac/sigsq
1862             fac=rrij*fac
1863 ! Calculate radial part of the gradient
1864             gg(1)=xj*fac
1865             gg(2)=yj*fac
1866             gg(3)=zj*fac
1867 ! Calculate the angular part of the gradient and sum add the contributions
1868 ! to the appropriate components of the Cartesian gradient.
1869             call sc_grad
1870           enddo      ! j
1871         enddo        ! iint
1872       enddo          ! i
1873 !     stop
1874       return
1875       end subroutine ebp
1876 !-----------------------------------------------------------------------------
1877       subroutine egb(evdw)
1878 !
1879 ! This subroutine calculates the interaction energy of nonbonded side chains
1880 ! assuming the Gay-Berne potential of interaction.
1881 !
1882       use calc_data
1883 !      implicit real*8 (a-h,o-z)
1884 !      include 'DIMENSIONS'
1885 !      include 'COMMON.GEO'
1886 !      include 'COMMON.VAR'
1887 !      include 'COMMON.LOCAL'
1888 !      include 'COMMON.CHAIN'
1889 !      include 'COMMON.DERIV'
1890 !      include 'COMMON.NAMES'
1891 !      include 'COMMON.INTERACT'
1892 !      include 'COMMON.IOUNITS'
1893 !      include 'COMMON.CALC'
1894 !      include 'COMMON.CONTROL'
1895 !      include 'COMMON.SBRIDGE'
1896       logical :: lprn
1897 !el local variables
1898       integer :: iint,itypi,itypi1,itypj,subchap,icont
1899       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1900       real(kind=8) :: evdw,sig0ij
1901       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1902                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1903                     sslipi,sslipj,faclip
1904       integer :: ii
1905       real(kind=8) :: fracinbuf
1906
1907 !cccc      energy_dec=.false.
1908 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1909       evdw=0.0D0
1910       lprn=.false.
1911 !     if (icall.eq.0) lprn=.false.
1912 !el      ind=0
1913       dCAVdOM2=0.0d0
1914       dGCLdOM2=0.0d0
1915       dPOLdOM2=0.0d0
1916       dCAVdOM1=0.0d0
1917       dGCLdOM1=0.0d0
1918       dPOLdOM1=0.0d0
1919 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1920       if (nres_molec(1).eq.0) return
1921       do icont=g_listscsc_start,g_listscsc_end
1922       i=newcontlisti(icont)
1923       j=newcontlistj(icont)
1924 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1925 !      do i=iatsc_s,iatsc_e
1926 !C        print *,"I am in EVDW",i
1927         itypi=iabs(itype(i,1))
1928 !        if (i.ne.47) cycle
1929         if (itypi.eq.ntyp1) cycle
1930         itypi1=iabs(itype(i+1,1))
1931         xi=c(1,nres+i)
1932         yi=c(2,nres+i)
1933         zi=c(3,nres+i)
1934         call to_box(xi,yi,zi)
1935         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1936
1937         dxi=dc_norm(1,nres+i)
1938         dyi=dc_norm(2,nres+i)
1939         dzi=dc_norm(3,nres+i)
1940 !        dsci_inv=dsc_inv(itypi)
1941         dsci_inv=vbld_inv(i+nres)
1942 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1943 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1944 !
1945 ! Calculate SC interaction energy.
1946 !
1947 !        do iint=1,nint_gr(i)
1948 !          do j=istart(i,iint),iend(i,iint)
1949             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1950               call dyn_ssbond_ene(i,j,evdwij)
1951               evdw=evdw+evdwij
1952               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1953                               'evdw',i,j,evdwij,' ss'
1954 !              if (energy_dec) write (iout,*) &
1955 !                              'evdw',i,j,evdwij,' ss'
1956              do k=j+1,nres
1957 !C search over all next residues
1958               if (dyn_ss_mask(k)) then
1959 !C check if they are cysteins
1960 !C              write(iout,*) 'k=',k
1961
1962 !c              write(iout,*) "PRZED TRI", evdwij
1963 !               evdwij_przed_tri=evdwij
1964               call triple_ssbond_ene(i,j,k,evdwij)
1965 !c               if(evdwij_przed_tri.ne.evdwij) then
1966 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1967 !c               endif
1968
1969 !c              write(iout,*) "PO TRI", evdwij
1970 !C call the energy function that removes the artifical triple disulfide
1971 !C bond the soubroutine is located in ssMD.F
1972               evdw=evdw+evdwij
1973               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1974                             'evdw',i,j,evdwij,'tss'
1975               endif!dyn_ss_mask(k)
1976              enddo! k
1977             ELSE
1978 !el            ind=ind+1
1979             itypj=iabs(itype(j,1))
1980             if (itypj.eq.ntyp1) cycle
1981 !             if (j.ne.78) cycle
1982 !            dscj_inv=dsc_inv(itypj)
1983             dscj_inv=vbld_inv(j+nres)
1984 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1985 !              1.0d0/vbld(j+nres) !d
1986 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1987             sig0ij=sigma(itypi,itypj)
1988             chi1=chi(itypi,itypj)
1989             chi2=chi(itypj,itypi)
1990             chi12=chi1*chi2
1991             chip1=chip(itypi)
1992             chip2=chip(itypj)
1993             chip12=chip1*chip2
1994             alf1=alp(itypi)
1995             alf2=alp(itypj)
1996             alf12=0.5D0*(alf1+alf2)
1997 ! For diagnostics only!!!
1998 !           chi1=0.0D0
1999 !           chi2=0.0D0
2000 !           chi12=0.0D0
2001 !           chip1=0.0D0
2002 !           chip2=0.0D0
2003 !           chip12=0.0D0
2004 !           alf1=0.0D0
2005 !           alf2=0.0D0
2006 !           alf12=0.0D0
2007            xj=c(1,nres+j)
2008            yj=c(2,nres+j)
2009            zj=c(3,nres+j)
2010               call to_box(xj,yj,zj)
2011               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2012 !              write (iout,*) "KWA2", itypi,itypj
2013               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2014                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2015               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2016                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2017               xj=boxshift(xj-xi,boxxsize)
2018               yj=boxshift(yj-yi,boxysize)
2019               zj=boxshift(zj-zi,boxzsize)
2020             dxj=dc_norm(1,nres+j)
2021             dyj=dc_norm(2,nres+j)
2022             dzj=dc_norm(3,nres+j)
2023 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2024 !            write (iout,*) "j",j," dc_norm",& !d
2025 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2026 !          write(iout,*)"rrij ",rrij
2027 !          write(iout,*)"xj yj zj ", xj, yj, zj
2028 !          write(iout,*)"xi yi zi ", xi, yi, zi
2029 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2030             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2031             rij=dsqrt(rrij)
2032             sss_ele_cut=sscale_ele(1.0d0/(rij))
2033             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2034 !            print *,sss_ele_cut,sss_ele_grad,&
2035 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2036             if (sss_ele_cut.le.0.0) cycle
2037 ! Calculate angle-dependent terms of energy and contributions to their
2038 ! derivatives.
2039             call sc_angular
2040             sigsq=1.0D0/sigsq
2041             sig=sig0ij*dsqrt(sigsq)
2042             rij_shift=1.0D0/rij-sig+sig0ij
2043 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2044 !            "sig0ij",sig0ij
2045 ! for diagnostics; uncomment
2046 !            rij_shift=1.2*sig0ij
2047 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2048             if (rij_shift.le.0.0D0) then
2049               evdw=1.0D20
2050 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2051 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2052 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2053               return
2054             endif
2055             sigder=-sig*sigsq
2056 !---------------------------------------------------------------
2057             rij_shift=1.0D0/rij_shift
2058             fac=rij_shift**expon
2059             faclip=fac
2060             e1=fac*fac*aa!(itypi,itypj)
2061             e2=fac*bb!(itypi,itypj)
2062             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2063             eps2der=evdwij*eps3rt
2064             eps3der=evdwij*eps2rt
2065 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2066 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2067 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2068             evdwij=evdwij*eps2rt*eps3rt
2069             evdw=evdw+evdwij*sss_ele_cut
2070             if (lprn) then
2071             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2072             epsi=bb**2/aa!(itypi,itypj)
2073             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2074               restyp(itypi,1),i,restyp(itypj,1),j, &
2075               epsi,sigm,chi1,chi2,chip1,chip2, &
2076               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2077               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2078               evdwij
2079             endif
2080
2081             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2082                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2083 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2084 !            if (energy_dec) write (iout,*) &
2085 !                             'evdw',i,j,evdwij
2086 !                       print *,"ZALAMKA", evdw
2087
2088 ! Calculate gradient components.
2089             e1=e1*eps1*eps2rt**2*eps3rt**2
2090             fac=-expon*(e1+evdwij)*rij_shift
2091             sigder=fac*sigder
2092             fac=rij*fac
2093 !            print *,'before fac',fac,rij,evdwij
2094             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2095             *rij
2096 !            print *,'grad part scale',fac,   &
2097 !             evdwij*sss_ele_grad/sss_ele_cut &
2098 !            /sigma(itypi,itypj)*rij
2099 !            fac=0.0d0
2100 ! Calculate the radial part of the gradient
2101             gg(1)=xj*fac
2102             gg(2)=yj*fac
2103             gg(3)=zj*fac
2104 !C Calculate the radial part of the gradient
2105             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2106        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2107         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2108        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2109             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2110             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2111
2112 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2113 ! Calculate angular part of the gradient.
2114             call sc_grad
2115             ENDIF    ! dyn_ss
2116 !          enddo      ! j
2117 !        enddo        ! iint
2118       enddo          ! i
2119 !       print *,"ZALAMKA", evdw
2120 !      write (iout,*) "Number of loop steps in EGB:",ind
2121 !ccc      energy_dec=.false.
2122       return
2123       end subroutine egb
2124 !-----------------------------------------------------------------------------
2125       subroutine egbv(evdw)
2126 !
2127 ! This subroutine calculates the interaction energy of nonbonded side chains
2128 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2129 !
2130       use comm_srutu
2131       use calc_data
2132 !      implicit real*8 (a-h,o-z)
2133 !      include 'DIMENSIONS'
2134 !      include 'COMMON.GEO'
2135 !      include 'COMMON.VAR'
2136 !      include 'COMMON.LOCAL'
2137 !      include 'COMMON.CHAIN'
2138 !      include 'COMMON.DERIV'
2139 !      include 'COMMON.NAMES'
2140 !      include 'COMMON.INTERACT'
2141 !      include 'COMMON.IOUNITS'
2142 !      include 'COMMON.CALC'
2143       use comm_srutu
2144 !el      integer :: icall
2145 !el      common /srutu/ icall
2146       logical :: lprn
2147 !el local variables
2148       integer :: iint,itypi,itypi1,itypj
2149       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2150          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2151       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2152
2153 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2154       evdw=0.0D0
2155       lprn=.false.
2156 !     if (icall.eq.0) lprn=.true.
2157 !el      ind=0
2158       do i=iatsc_s,iatsc_e
2159         itypi=iabs(itype(i,1))
2160         if (itypi.eq.ntyp1) cycle
2161         itypi1=iabs(itype(i+1,1))
2162         xi=c(1,nres+i)
2163         yi=c(2,nres+i)
2164         zi=c(3,nres+i)
2165         call to_box(xi,yi,zi)
2166         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2167         dxi=dc_norm(1,nres+i)
2168         dyi=dc_norm(2,nres+i)
2169         dzi=dc_norm(3,nres+i)
2170 !        dsci_inv=dsc_inv(itypi)
2171         dsci_inv=vbld_inv(i+nres)
2172 !
2173 ! Calculate SC interaction energy.
2174 !
2175         do iint=1,nint_gr(i)
2176           do j=istart(i,iint),iend(i,iint)
2177 !el            ind=ind+1
2178             itypj=iabs(itype(j,1))
2179             if (itypj.eq.ntyp1) cycle
2180 !            dscj_inv=dsc_inv(itypj)
2181             dscj_inv=vbld_inv(j+nres)
2182             sig0ij=sigma(itypi,itypj)
2183             r0ij=r0(itypi,itypj)
2184             chi1=chi(itypi,itypj)
2185             chi2=chi(itypj,itypi)
2186             chi12=chi1*chi2
2187             chip1=chip(itypi)
2188             chip2=chip(itypj)
2189             chip12=chip1*chip2
2190             alf1=alp(itypi)
2191             alf2=alp(itypj)
2192             alf12=0.5D0*(alf1+alf2)
2193 ! For diagnostics only!!!
2194 !           chi1=0.0D0
2195 !           chi2=0.0D0
2196 !           chi12=0.0D0
2197 !           chip1=0.0D0
2198 !           chip2=0.0D0
2199 !           chip12=0.0D0
2200 !           alf1=0.0D0
2201 !           alf2=0.0D0
2202 !           alf12=0.0D0
2203             xj=c(1,nres+j)-xi
2204             yj=c(2,nres+j)-yi
2205             zj=c(3,nres+j)-zi
2206            call to_box(xj,yj,zj)
2207            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2208            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2209             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2210            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2211             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2212            xj=boxshift(xj-xi,boxxsize)
2213            yj=boxshift(yj-yi,boxysize)
2214            zj=boxshift(zj-zi,boxzsize)
2215             dxj=dc_norm(1,nres+j)
2216             dyj=dc_norm(2,nres+j)
2217             dzj=dc_norm(3,nres+j)
2218             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2219             rij=dsqrt(rrij)
2220 ! Calculate angle-dependent terms of energy and contributions to their
2221 ! derivatives.
2222             call sc_angular
2223             sigsq=1.0D0/sigsq
2224             sig=sig0ij*dsqrt(sigsq)
2225             rij_shift=1.0D0/rij-sig+r0ij
2226 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2227             if (rij_shift.le.0.0D0) then
2228               evdw=1.0D20
2229               return
2230             endif
2231             sigder=-sig*sigsq
2232 !---------------------------------------------------------------
2233             rij_shift=1.0D0/rij_shift
2234             fac=rij_shift**expon
2235             e1=fac*fac*aa_aq(itypi,itypj)
2236             e2=fac*bb_aq(itypi,itypj)
2237             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2238             eps2der=evdwij*eps3rt
2239             eps3der=evdwij*eps2rt
2240             fac_augm=rrij**expon
2241             e_augm=augm(itypi,itypj)*fac_augm
2242             evdwij=evdwij*eps2rt*eps3rt
2243             evdw=evdw+evdwij+e_augm
2244             if (lprn) then
2245             sigm=dabs(aa_aq(itypi,itypj)/&
2246             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2247             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2248             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2249               restyp(itypi,1),i,restyp(itypj,1),j,&
2250               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2251               chi1,chi2,chip1,chip2,&
2252               eps1,eps2rt**2,eps3rt**2,&
2253               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2254               evdwij+e_augm
2255             endif
2256 ! Calculate gradient components.
2257             e1=e1*eps1*eps2rt**2*eps3rt**2
2258             fac=-expon*(e1+evdwij)*rij_shift
2259             sigder=fac*sigder
2260             fac=rij*fac-2*expon*rrij*e_augm
2261 ! Calculate the radial part of the gradient
2262             gg(1)=xj*fac
2263             gg(2)=yj*fac
2264             gg(3)=zj*fac
2265 ! Calculate angular part of the gradient.
2266             call sc_grad
2267           enddo      ! j
2268         enddo        ! iint
2269       enddo          ! i
2270       end subroutine egbv
2271 !-----------------------------------------------------------------------------
2272 !el      subroutine sc_angular in module geometry
2273 !-----------------------------------------------------------------------------
2274       subroutine e_softsphere(evdw)
2275 !
2276 ! This subroutine calculates the interaction energy of nonbonded side chains
2277 ! assuming the LJ potential of interaction.
2278 !
2279 !      implicit real*8 (a-h,o-z)
2280 !      include 'DIMENSIONS'
2281       real(kind=8),parameter :: accur=1.0d-10
2282 !      include 'COMMON.GEO'
2283 !      include 'COMMON.VAR'
2284 !      include 'COMMON.LOCAL'
2285 !      include 'COMMON.CHAIN'
2286 !      include 'COMMON.DERIV'
2287 !      include 'COMMON.INTERACT'
2288 !      include 'COMMON.TORSION'
2289 !      include 'COMMON.SBRIDGE'
2290 !      include 'COMMON.NAMES'
2291 !      include 'COMMON.IOUNITS'
2292 !      include 'COMMON.CONTACTS'
2293       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2294 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2295 !el local variables
2296       integer :: i,iint,j,itypi,itypi1,itypj,k
2297       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2298       real(kind=8) :: fac
2299
2300       evdw=0.0D0
2301       do i=iatsc_s,iatsc_e
2302         itypi=iabs(itype(i,1))
2303         if (itypi.eq.ntyp1) cycle
2304         itypi1=iabs(itype(i+1,1))
2305         xi=c(1,nres+i)
2306         yi=c(2,nres+i)
2307         zi=c(3,nres+i)
2308         call to_box(xi,yi,zi)
2309
2310 !
2311 ! Calculate SC interaction energy.
2312 !
2313         do iint=1,nint_gr(i)
2314 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2315 !d   &                  'iend=',iend(i,iint)
2316           do j=istart(i,iint),iend(i,iint)
2317             itypj=iabs(itype(j,1))
2318             if (itypj.eq.ntyp1) cycle
2319             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2320             yj=boxshift(c(2,nres+j)-yi,boxysize)
2321             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2322             rij=xj*xj+yj*yj+zj*zj
2323 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2324             r0ij=r0(itypi,itypj)
2325             r0ijsq=r0ij*r0ij
2326 !            print *,i,j,r0ij,dsqrt(rij)
2327             if (rij.lt.r0ijsq) then
2328               evdwij=0.25d0*(rij-r0ijsq)**2
2329               fac=rij-r0ijsq
2330             else
2331               evdwij=0.0d0
2332               fac=0.0d0
2333             endif
2334             evdw=evdw+evdwij
2335 !
2336 ! Calculate the components of the gradient in DC and X
2337 !
2338             gg(1)=xj*fac
2339             gg(2)=yj*fac
2340             gg(3)=zj*fac
2341             do k=1,3
2342               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2343               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2344               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2345               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2346             enddo
2347 !grad            do k=i,j-1
2348 !grad              do l=1,3
2349 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2350 !grad              enddo
2351 !grad            enddo
2352           enddo ! j
2353         enddo ! iint
2354       enddo ! i
2355       return
2356       end subroutine e_softsphere
2357 !-----------------------------------------------------------------------------
2358       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2359 !
2360 ! Soft-sphere potential of p-p interaction
2361 !
2362 !      implicit real*8 (a-h,o-z)
2363 !      include 'DIMENSIONS'
2364 !      include 'COMMON.CONTROL'
2365 !      include 'COMMON.IOUNITS'
2366 !      include 'COMMON.GEO'
2367 !      include 'COMMON.VAR'
2368 !      include 'COMMON.LOCAL'
2369 !      include 'COMMON.CHAIN'
2370 !      include 'COMMON.DERIV'
2371 !      include 'COMMON.INTERACT'
2372 !      include 'COMMON.CONTACTS'
2373 !      include 'COMMON.TORSION'
2374 !      include 'COMMON.VECTORS'
2375 !      include 'COMMON.FFIELD'
2376       real(kind=8),dimension(3) :: ggg
2377 !d      write(iout,*) 'In EELEC_soft_sphere'
2378 !el local variables
2379       integer :: i,j,k,num_conti,iteli,itelj
2380       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2381       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2382       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2383
2384       ees=0.0D0
2385       evdw1=0.0D0
2386       eel_loc=0.0d0
2387       eello_turn3=0.0d0
2388       eello_turn4=0.0d0
2389 !el      ind=0
2390       do i=iatel_s,iatel_e
2391         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2392         dxi=dc(1,i)
2393         dyi=dc(2,i)
2394         dzi=dc(3,i)
2395         xmedi=c(1,i)+0.5d0*dxi
2396         ymedi=c(2,i)+0.5d0*dyi
2397         zmedi=c(3,i)+0.5d0*dzi
2398         call to_box(xmedi,ymedi,zmedi)
2399         num_conti=0
2400 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2401         do j=ielstart(i),ielend(i)
2402           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2403 !el          ind=ind+1
2404           iteli=itel(i)
2405           itelj=itel(j)
2406           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2407           r0ij=rpp(iteli,itelj)
2408           r0ijsq=r0ij*r0ij
2409           dxj=dc(1,j)
2410           dyj=dc(2,j)
2411           dzj=dc(3,j)
2412           xj=c(1,j)+0.5D0*dxj-xmedi
2413           yj=c(2,j)+0.5D0*dyj-ymedi
2414           zj=c(3,j)+0.5D0*dzj-zmedi
2415           call to_box(xj,yj,zj)
2416           xj=boxshift(xj-xmedi,boxxsize)
2417           yj=boxshift(yj-ymedi,boxysize)
2418           zj=boxshift(zj-zmedi,boxzsize)
2419           rij=xj*xj+yj*yj+zj*zj
2420           if (rij.lt.r0ijsq) then
2421             evdw1ij=0.25d0*(rij-r0ijsq)**2
2422             fac=rij-r0ijsq
2423           else
2424             evdw1ij=0.0d0
2425             fac=0.0d0
2426           endif
2427           evdw1=evdw1+evdw1ij
2428 !
2429 ! Calculate contributions to the Cartesian gradient.
2430 !
2431           ggg(1)=fac*xj
2432           ggg(2)=fac*yj
2433           ggg(3)=fac*zj
2434           do k=1,3
2435             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2436             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2437           enddo
2438 !
2439 ! Loop over residues i+1 thru j-1.
2440 !
2441 !grad          do k=i+1,j-1
2442 !grad            do l=1,3
2443 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2444 !grad            enddo
2445 !grad          enddo
2446         enddo ! j
2447       enddo   ! i
2448 !grad      do i=nnt,nct-1
2449 !grad        do k=1,3
2450 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2451 !grad        enddo
2452 !grad        do j=i+1,nct-1
2453 !grad          do k=1,3
2454 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2455 !grad          enddo
2456 !grad        enddo
2457 !grad      enddo
2458       return
2459       end subroutine eelec_soft_sphere
2460 !-----------------------------------------------------------------------------
2461       subroutine vec_and_deriv
2462 !      implicit real*8 (a-h,o-z)
2463 !      include 'DIMENSIONS'
2464 #ifdef MPI
2465       include 'mpif.h'
2466 #endif
2467 !      include 'COMMON.IOUNITS'
2468 !      include 'COMMON.GEO'
2469 !      include 'COMMON.VAR'
2470 !      include 'COMMON.LOCAL'
2471 !      include 'COMMON.CHAIN'
2472 !      include 'COMMON.VECTORS'
2473 !      include 'COMMON.SETUP'
2474 !      include 'COMMON.TIME1'
2475       real(kind=8),dimension(3,3,2) :: uyder,uzder
2476       real(kind=8),dimension(2) :: vbld_inv_temp
2477 ! Compute the local reference systems. For reference system (i), the
2478 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2479 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2480 !el local variables
2481       integer :: i,j,k,l
2482       real(kind=8) :: facy,fac,costh
2483
2484 #ifdef PARVEC
2485       do i=ivec_start,ivec_end
2486 #else
2487       do i=1,nres-1
2488 #endif
2489           if (i.eq.nres-1) then
2490 ! Case of the last full residue
2491 ! Compute the Z-axis
2492             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2493             costh=dcos(pi-theta(nres))
2494             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2495             do k=1,3
2496               uz(k,i)=fac*uz(k,i)
2497             enddo
2498 ! Compute the derivatives of uz
2499             uzder(1,1,1)= 0.0d0
2500             uzder(2,1,1)=-dc_norm(3,i-1)
2501             uzder(3,1,1)= dc_norm(2,i-1)
2502             uzder(1,2,1)= dc_norm(3,i-1)
2503             uzder(2,2,1)= 0.0d0
2504             uzder(3,2,1)=-dc_norm(1,i-1)
2505             uzder(1,3,1)=-dc_norm(2,i-1)
2506             uzder(2,3,1)= dc_norm(1,i-1)
2507             uzder(3,3,1)= 0.0d0
2508             uzder(1,1,2)= 0.0d0
2509             uzder(2,1,2)= dc_norm(3,i)
2510             uzder(3,1,2)=-dc_norm(2,i)
2511             uzder(1,2,2)=-dc_norm(3,i)
2512             uzder(2,2,2)= 0.0d0
2513             uzder(3,2,2)= dc_norm(1,i)
2514             uzder(1,3,2)= dc_norm(2,i)
2515             uzder(2,3,2)=-dc_norm(1,i)
2516             uzder(3,3,2)= 0.0d0
2517 ! Compute the Y-axis
2518             facy=fac
2519             do k=1,3
2520               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2521             enddo
2522 ! Compute the derivatives of uy
2523             do j=1,3
2524               do k=1,3
2525                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2526                               -dc_norm(k,i)*dc_norm(j,i-1)
2527                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2528               enddo
2529               uyder(j,j,1)=uyder(j,j,1)-costh
2530               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2531             enddo
2532             do j=1,2
2533               do k=1,3
2534                 do l=1,3
2535                   uygrad(l,k,j,i)=uyder(l,k,j)
2536                   uzgrad(l,k,j,i)=uzder(l,k,j)
2537                 enddo
2538               enddo
2539             enddo
2540             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2541             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2542             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2543             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2544           else
2545 ! Other residues
2546 ! Compute the Z-axis
2547             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2548             costh=dcos(pi-theta(i+2))
2549             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2550             do k=1,3
2551               uz(k,i)=fac*uz(k,i)
2552             enddo
2553 ! Compute the derivatives of uz
2554             uzder(1,1,1)= 0.0d0
2555             uzder(2,1,1)=-dc_norm(3,i+1)
2556             uzder(3,1,1)= dc_norm(2,i+1)
2557             uzder(1,2,1)= dc_norm(3,i+1)
2558             uzder(2,2,1)= 0.0d0
2559             uzder(3,2,1)=-dc_norm(1,i+1)
2560             uzder(1,3,1)=-dc_norm(2,i+1)
2561             uzder(2,3,1)= dc_norm(1,i+1)
2562             uzder(3,3,1)= 0.0d0
2563             uzder(1,1,2)= 0.0d0
2564             uzder(2,1,2)= dc_norm(3,i)
2565             uzder(3,1,2)=-dc_norm(2,i)
2566             uzder(1,2,2)=-dc_norm(3,i)
2567             uzder(2,2,2)= 0.0d0
2568             uzder(3,2,2)= dc_norm(1,i)
2569             uzder(1,3,2)= dc_norm(2,i)
2570             uzder(2,3,2)=-dc_norm(1,i)
2571             uzder(3,3,2)= 0.0d0
2572 ! Compute the Y-axis
2573             facy=fac
2574             do k=1,3
2575               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2576             enddo
2577 ! Compute the derivatives of uy
2578             do j=1,3
2579               do k=1,3
2580                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2581                               -dc_norm(k,i)*dc_norm(j,i+1)
2582                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2583               enddo
2584               uyder(j,j,1)=uyder(j,j,1)-costh
2585               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2586             enddo
2587             do j=1,2
2588               do k=1,3
2589                 do l=1,3
2590                   uygrad(l,k,j,i)=uyder(l,k,j)
2591                   uzgrad(l,k,j,i)=uzder(l,k,j)
2592                 enddo
2593               enddo
2594             enddo
2595             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2596             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2597             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2598             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2599           endif
2600       enddo
2601       do i=1,nres-1
2602         vbld_inv_temp(1)=vbld_inv(i+1)
2603         if (i.lt.nres-1) then
2604           vbld_inv_temp(2)=vbld_inv(i+2)
2605           else
2606           vbld_inv_temp(2)=vbld_inv(i)
2607           endif
2608         do j=1,2
2609           do k=1,3
2610             do l=1,3
2611               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2612               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2613             enddo
2614           enddo
2615         enddo
2616       enddo
2617 #if defined(PARVEC) && defined(MPI)
2618       if (nfgtasks1.gt.1) then
2619         time00=MPI_Wtime()
2620 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2621 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2622 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2623         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2624          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2625          FG_COMM1,IERR)
2626         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2627          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2628          FG_COMM1,IERR)
2629         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2630          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2631          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2632         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2633          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2634          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2635         time_gather=time_gather+MPI_Wtime()-time00
2636       endif
2637 !      if (fg_rank.eq.0) then
2638 !        write (iout,*) "Arrays UY and UZ"
2639 !        do i=1,nres-1
2640 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2641 !     &     (uz(k,i),k=1,3)
2642 !        enddo
2643 !      endif
2644 #endif
2645       return
2646       end subroutine vec_and_deriv
2647 !-----------------------------------------------------------------------------
2648       subroutine check_vecgrad
2649 !      implicit real*8 (a-h,o-z)
2650 !      include 'DIMENSIONS'
2651 !      include 'COMMON.IOUNITS'
2652 !      include 'COMMON.GEO'
2653 !      include 'COMMON.VAR'
2654 !      include 'COMMON.LOCAL'
2655 !      include 'COMMON.CHAIN'
2656 !      include 'COMMON.VECTORS'
2657       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2658       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2659       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2660       real(kind=8),dimension(3) :: erij
2661       real(kind=8) :: delta=1.0d-7
2662 !el local variables
2663       integer :: i,j,k,l
2664
2665       call vec_and_deriv
2666 !d      do i=1,nres
2667 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2668 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2669 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2670 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2671 !d     &     (dc_norm(if90,i),if90=1,3)
2672 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2673 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2674 !d          write(iout,'(a)')
2675 !d      enddo
2676       do i=1,nres
2677         do j=1,2
2678           do k=1,3
2679             do l=1,3
2680               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2681               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2682             enddo
2683           enddo
2684         enddo
2685       enddo
2686       call vec_and_deriv
2687       do i=1,nres
2688         do j=1,3
2689           uyt(j,i)=uy(j,i)
2690           uzt(j,i)=uz(j,i)
2691         enddo
2692       enddo
2693       do i=1,nres
2694 !d        write (iout,*) 'i=',i
2695         do k=1,3
2696           erij(k)=dc_norm(k,i)
2697         enddo
2698         do j=1,3
2699           do k=1,3
2700             dc_norm(k,i)=erij(k)
2701           enddo
2702           dc_norm(j,i)=dc_norm(j,i)+delta
2703 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2704 !          do k=1,3
2705 !            dc_norm(k,i)=dc_norm(k,i)/fac
2706 !          enddo
2707 !          write (iout,*) (dc_norm(k,i),k=1,3)
2708 !          write (iout,*) (erij(k),k=1,3)
2709           call vec_and_deriv
2710           do k=1,3
2711             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2712             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2713             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2714             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2715           enddo
2716 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2717 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2718 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2719         enddo
2720         do k=1,3
2721           dc_norm(k,i)=erij(k)
2722         enddo
2723 !d        do k=1,3
2724 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2725 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2726 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2727 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2728 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2729 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2730 !d          write (iout,'(a)')
2731 !d        enddo
2732       enddo
2733       return
2734       end subroutine check_vecgrad
2735 !-----------------------------------------------------------------------------
2736       subroutine set_matrices
2737 !      implicit real*8 (a-h,o-z)
2738 !      include 'DIMENSIONS'
2739 #ifdef MPI
2740       include "mpif.h"
2741 !      include "COMMON.SETUP"
2742       integer :: IERR
2743       integer :: status(MPI_STATUS_SIZE)
2744 #endif
2745 !      include 'COMMON.IOUNITS'
2746 !      include 'COMMON.GEO'
2747 !      include 'COMMON.VAR'
2748 !      include 'COMMON.LOCAL'
2749 !      include 'COMMON.CHAIN'
2750 !      include 'COMMON.DERIV'
2751 !      include 'COMMON.INTERACT'
2752 !      include 'COMMON.CONTACTS'
2753 !      include 'COMMON.TORSION'
2754 !      include 'COMMON.VECTORS'
2755 !      include 'COMMON.FFIELD'
2756       real(kind=8) :: auxvec(2),auxmat(2,2)
2757       integer :: i,iti1,iti,k,l
2758       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2759        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2760 !       print *,"in set matrices"
2761 !
2762 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2763 ! to calculate the el-loc multibody terms of various order.
2764 !
2765 !AL el      mu=0.0d0
2766
2767 #ifdef PARMAT
2768       do i=ivec_start+2,ivec_end+2
2769 #else
2770       do i=3,nres+1
2771 #endif
2772         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2773           if (itype(i-2,1).eq.0) then
2774           iti = nloctyp
2775           else
2776           iti = itype2loc(itype(i-2,1))
2777           endif
2778         else
2779           iti=nloctyp
2780         endif
2781 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2782         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2783           iti1 = itype2loc(itype(i-1,1))
2784         else
2785           iti1=nloctyp
2786         endif
2787 !        print *,i,itype(i-2,1),iti
2788 #ifdef NEWCORR
2789         cost1=dcos(theta(i-1))
2790         sint1=dsin(theta(i-1))
2791         sint1sq=sint1*sint1
2792         sint1cub=sint1sq*sint1
2793         sint1cost1=2*sint1*cost1
2794 !        print *,"cost1",cost1,theta(i-1)
2795 !c        write (iout,*) "bnew1",i,iti
2796 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2797 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2798 !c        write (iout,*) "bnew2",i,iti
2799 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2800 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2801         k=1
2802 !        print *,bnew1(1,k,iti),"bnew1"
2803         do k=1,2
2804           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2805 !          print *,b1k
2806 !          write(*,*) shape(b1)
2807 !          if(.not.allocated(b1)) print *, "WTF?"
2808           b1(k,i-2)=sint1*b1k
2809 !
2810 !             print *,b1(k,i-2)
2811
2812           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2813                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2814 !             print *,gtb1(k,i-2)
2815
2816           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2817           b2(k,i-2)=sint1*b2k
2818 !             print *,b2(k,i-2)
2819
2820           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2821                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2822 !             print *,gtb2(k,i-2)
2823
2824         enddo
2825 !        print *,b1k,b2k
2826         do k=1,2
2827           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2828           cc(1,k,i-2)=sint1sq*aux
2829           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2830                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2831           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2832           dd(1,k,i-2)=sint1sq*aux
2833           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2834                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2835         enddo
2836 !        print *,"after cc"
2837         cc(2,1,i-2)=cc(1,2,i-2)
2838         cc(2,2,i-2)=-cc(1,1,i-2)
2839         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2840         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2841         dd(2,1,i-2)=dd(1,2,i-2)
2842         dd(2,2,i-2)=-dd(1,1,i-2)
2843         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2844         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2845 !        print *,"after dd"
2846
2847         do k=1,2
2848           do l=1,2
2849             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2850             EE(l,k,i-2)=sint1sq*aux
2851             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2852           enddo
2853         enddo
2854         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2855         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2856         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2857         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2858         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2859         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2860         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2861 !        print *,"after ee"
2862
2863 !c        b1tilde(1,i-2)=b1(1,i-2)
2864 !c        b1tilde(2,i-2)=-b1(2,i-2)
2865 !c        b2tilde(1,i-2)=b2(1,i-2)
2866 !c        b2tilde(2,i-2)=-b2(2,i-2)
2867 #ifdef DEBUG
2868         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2869         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2870         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2871         write (iout,*) 'theta=', theta(i-1)
2872 #endif
2873 #else
2874         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2875 !         write(iout,*) "i,",molnum(i),nloctyp
2876 !         print *, "i,",molnum(i),i,itype(i-2,1)
2877         if (molnum(i).eq.1) then
2878           if (itype(i-2,1).eq.ntyp1) then
2879            iti=nloctyp
2880           else
2881           iti = itype2loc(itype(i-2,1))
2882           endif
2883         else
2884           iti=nloctyp
2885         endif
2886         else
2887           iti=nloctyp
2888         endif
2889 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2890 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2891         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2892           iti1 = itype2loc(itype(i-1,1))
2893         else
2894           iti1=nloctyp
2895         endif
2896 !        print *,i,iti
2897         b1(1,i-2)=b(3,iti)
2898         b1(2,i-2)=b(5,iti)
2899         b2(1,i-2)=b(2,iti)
2900         b2(2,i-2)=b(4,iti)
2901         do k=1,2
2902           do l=1,2
2903            CC(k,l,i-2)=ccold(k,l,iti)
2904            DD(k,l,i-2)=ddold(k,l,iti)
2905            EE(k,l,i-2)=eeold(k,l,iti)
2906           enddo
2907         enddo
2908 #endif
2909         b1tilde(1,i-2)= b1(1,i-2)
2910         b1tilde(2,i-2)=-b1(2,i-2)
2911         b2tilde(1,i-2)= b2(1,i-2)
2912         b2tilde(2,i-2)=-b2(2,i-2)
2913 !c
2914         Ctilde(1,1,i-2)= CC(1,1,i-2)
2915         Ctilde(1,2,i-2)= CC(1,2,i-2)
2916         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2917         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2918 !c
2919         Dtilde(1,1,i-2)= DD(1,1,i-2)
2920         Dtilde(1,2,i-2)= DD(1,2,i-2)
2921         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2922         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2923       enddo
2924 #ifdef PARMAT
2925       do i=ivec_start+2,ivec_end+2
2926 #else
2927       do i=3,nres+1
2928 #endif
2929
2930 !      print *,i,"i"
2931         if (i .lt. nres+1) then
2932           sin1=dsin(phi(i))
2933           cos1=dcos(phi(i))
2934           sintab(i-2)=sin1
2935           costab(i-2)=cos1
2936           obrot(1,i-2)=cos1
2937           obrot(2,i-2)=sin1
2938           sin2=dsin(2*phi(i))
2939           cos2=dcos(2*phi(i))
2940           sintab2(i-2)=sin2
2941           costab2(i-2)=cos2
2942           obrot2(1,i-2)=cos2
2943           obrot2(2,i-2)=sin2
2944           Ug(1,1,i-2)=-cos1
2945           Ug(1,2,i-2)=-sin1
2946           Ug(2,1,i-2)=-sin1
2947           Ug(2,2,i-2)= cos1
2948           Ug2(1,1,i-2)=-cos2
2949           Ug2(1,2,i-2)=-sin2
2950           Ug2(2,1,i-2)=-sin2
2951           Ug2(2,2,i-2)= cos2
2952         else
2953           costab(i-2)=1.0d0
2954           sintab(i-2)=0.0d0
2955           obrot(1,i-2)=1.0d0
2956           obrot(2,i-2)=0.0d0
2957           obrot2(1,i-2)=0.0d0
2958           obrot2(2,i-2)=0.0d0
2959           Ug(1,1,i-2)=1.0d0
2960           Ug(1,2,i-2)=0.0d0
2961           Ug(2,1,i-2)=0.0d0
2962           Ug(2,2,i-2)=1.0d0
2963           Ug2(1,1,i-2)=0.0d0
2964           Ug2(1,2,i-2)=0.0d0
2965           Ug2(2,1,i-2)=0.0d0
2966           Ug2(2,2,i-2)=0.0d0
2967         endif
2968         if (i .gt. 3 .and. i .lt. nres+1) then
2969           obrot_der(1,i-2)=-sin1
2970           obrot_der(2,i-2)= cos1
2971           Ugder(1,1,i-2)= sin1
2972           Ugder(1,2,i-2)=-cos1
2973           Ugder(2,1,i-2)=-cos1
2974           Ugder(2,2,i-2)=-sin1
2975           dwacos2=cos2+cos2
2976           dwasin2=sin2+sin2
2977           obrot2_der(1,i-2)=-dwasin2
2978           obrot2_der(2,i-2)= dwacos2
2979           Ug2der(1,1,i-2)= dwasin2
2980           Ug2der(1,2,i-2)=-dwacos2
2981           Ug2der(2,1,i-2)=-dwacos2
2982           Ug2der(2,2,i-2)=-dwasin2
2983         else
2984           obrot_der(1,i-2)=0.0d0
2985           obrot_der(2,i-2)=0.0d0
2986           Ugder(1,1,i-2)=0.0d0
2987           Ugder(1,2,i-2)=0.0d0
2988           Ugder(2,1,i-2)=0.0d0
2989           Ugder(2,2,i-2)=0.0d0
2990           obrot2_der(1,i-2)=0.0d0
2991           obrot2_der(2,i-2)=0.0d0
2992           Ug2der(1,1,i-2)=0.0d0
2993           Ug2der(1,2,i-2)=0.0d0
2994           Ug2der(2,1,i-2)=0.0d0
2995           Ug2der(2,2,i-2)=0.0d0
2996         endif
2997 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2998         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2999            if (itype(i-2,1).eq.0) then
3000           iti=ntortyp+1
3001            else
3002           iti = itype2loc(itype(i-2,1))
3003            endif
3004         else
3005           iti=nloctyp
3006         endif
3007 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3008         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3009            if (itype(i-1,1).eq.0) then
3010           iti1=nloctyp
3011            else
3012           iti1 = itype2loc(itype(i-1,1))
3013            endif
3014         else
3015           iti1=nloctyp
3016         endif
3017 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3018 !d        write (iout,*) '*******i',i,' iti1',iti
3019 !        write (iout,*) 'b1',b1(:,iti)
3020 !        write (iout,*) 'b2',b2(:,i-2)
3021 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3022 !        if (i .gt. iatel_s+2) then
3023         if (i .gt. nnt+2) then
3024           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3025 #ifdef NEWCORR
3026           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3027 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3028 #endif
3029
3030           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3031           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3032           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3033           then
3034           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3035           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3036           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3037           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3038           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3039           endif
3040         else
3041           do k=1,2
3042             Ub2(k,i-2)=0.0d0
3043             Ctobr(k,i-2)=0.0d0
3044             Dtobr2(k,i-2)=0.0d0
3045             do l=1,2
3046               EUg(l,k,i-2)=0.0d0
3047               CUg(l,k,i-2)=0.0d0
3048               DUg(l,k,i-2)=0.0d0
3049               DtUg2(l,k,i-2)=0.0d0
3050             enddo
3051           enddo
3052         endif
3053         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3054         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3055         do k=1,2
3056           muder(k,i-2)=Ub2der(k,i-2)
3057         enddo
3058 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3059         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3060           if (itype(i-1,1).eq.0) then
3061            iti1=nloctyp
3062           elseif (itype(i-1,1).le.ntyp) then
3063             iti1 = itype2loc(itype(i-1,1))
3064           else
3065             iti1=nloctyp
3066           endif
3067         else
3068           iti1=nloctyp
3069         endif
3070         do k=1,2
3071           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3072         enddo
3073         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3074         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3075         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3076 !d        write (iout,*) 'mu1',mu1(:,i-2)
3077 !d        write (iout,*) 'mu2',mu2(:,i-2)
3078         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3079         then
3080         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3081         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3082         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3083         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3084         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3085 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3086         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3087         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3088         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3089         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3090         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3091         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3092         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3093         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3094         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3095         endif
3096       enddo
3097 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3098 ! The order of matrices is from left to right.
3099       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3100       then
3101 !      do i=max0(ivec_start,2),ivec_end
3102       do i=2,nres-1
3103         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3104         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3105         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3106         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3107         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3108         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3109         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3110         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3111       enddo
3112       endif
3113 #if defined(MPI) && defined(PARMAT)
3114 #ifdef DEBUG
3115 !      if (fg_rank.eq.0) then
3116         write (iout,*) "Arrays UG and UGDER before GATHER"
3117         do i=1,nres-1
3118           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3119            ((ug(l,k,i),l=1,2),k=1,2),&
3120            ((ugder(l,k,i),l=1,2),k=1,2)
3121         enddo
3122         write (iout,*) "Arrays UG2 and UG2DER"
3123         do i=1,nres-1
3124           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3125            ((ug2(l,k,i),l=1,2),k=1,2),&
3126            ((ug2der(l,k,i),l=1,2),k=1,2)
3127         enddo
3128         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3129         do i=1,nres-1
3130           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3131            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3132            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3133         enddo
3134         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3135         do i=1,nres-1
3136           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3137            costab(i),sintab(i),costab2(i),sintab2(i)
3138         enddo
3139         write (iout,*) "Array MUDER"
3140         do i=1,nres-1
3141           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3142         enddo
3143 !      endif
3144 #endif
3145       if (nfgtasks.gt.1) then
3146         time00=MPI_Wtime()
3147 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3148 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3149 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3150 #ifdef MATGATHER
3151         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3152          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3153          FG_COMM1,IERR)
3154         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3155          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3156          FG_COMM1,IERR)
3157         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3158          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3159          FG_COMM1,IERR)
3160         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3161          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3162          FG_COMM1,IERR)
3163         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3164          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3165          FG_COMM1,IERR)
3166         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3167          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3168          FG_COMM1,IERR)
3169         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3170          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3171          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3172         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3173          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3174          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3175         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3176          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3177          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3178         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3179          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3180          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3181         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3182         then
3183         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3184          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3185          FG_COMM1,IERR)
3186         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3187          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3188          FG_COMM1,IERR)
3189         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3190          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3191          FG_COMM1,IERR)
3192        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3193          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3194          FG_COMM1,IERR)
3195         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3196          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3197          FG_COMM1,IERR)
3198         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3199          ivec_count(fg_rank1),&
3200          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3201          FG_COMM1,IERR)
3202         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3203          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3204          FG_COMM1,IERR)
3205         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3206          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3207          FG_COMM1,IERR)
3208         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3209          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3210          FG_COMM1,IERR)
3211         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3212          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3213          FG_COMM1,IERR)
3214         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3215          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3216          FG_COMM1,IERR)
3217         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3218          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3219          FG_COMM1,IERR)
3220         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3221          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3222          FG_COMM1,IERR)
3223         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3224          ivec_count(fg_rank1),&
3225          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3226          FG_COMM1,IERR)
3227         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3228          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3229          FG_COMM1,IERR)
3230        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3231          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3232          FG_COMM1,IERR)
3233         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3234          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3235          FG_COMM1,IERR)
3236        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3237          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3238          FG_COMM1,IERR)
3239         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3240          ivec_count(fg_rank1),&
3241          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3242          FG_COMM1,IERR)
3243         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3244          ivec_count(fg_rank1),&
3245          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3246          FG_COMM1,IERR)
3247         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3248          ivec_count(fg_rank1),&
3249          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3250          MPI_MAT2,FG_COMM1,IERR)
3251         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3252          ivec_count(fg_rank1),&
3253          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3254          MPI_MAT2,FG_COMM1,IERR)
3255         endif
3256 #else
3257 ! Passes matrix info through the ring
3258       isend=fg_rank1
3259       irecv=fg_rank1-1
3260       if (irecv.lt.0) irecv=nfgtasks1-1
3261       iprev=irecv
3262       inext=fg_rank1+1
3263       if (inext.ge.nfgtasks1) inext=0
3264       do i=1,nfgtasks1-1
3265 !        write (iout,*) "isend",isend," irecv",irecv
3266 !        call flush(iout)
3267         lensend=lentyp(isend)
3268         lenrecv=lentyp(irecv)
3269 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3270 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3271 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3272 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3273 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3274 !        write (iout,*) "Gather ROTAT1"
3275 !        call flush(iout)
3276 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3277 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3278 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3279 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3280 !        write (iout,*) "Gather ROTAT2"
3281 !        call flush(iout)
3282         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3283          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3284          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3285          iprev,4400+irecv,FG_COMM,status,IERR)
3286 !        write (iout,*) "Gather ROTAT_OLD"
3287 !        call flush(iout)
3288         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3289          MPI_PRECOMP11(lensend),inext,5500+isend,&
3290          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3291          iprev,5500+irecv,FG_COMM,status,IERR)
3292 !        write (iout,*) "Gather PRECOMP11"
3293 !        call flush(iout)
3294         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3295          MPI_PRECOMP12(lensend),inext,6600+isend,&
3296          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3297          iprev,6600+irecv,FG_COMM,status,IERR)
3298 !        write (iout,*) "Gather PRECOMP12"
3299 !        call flush(iout)
3300         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3301         then
3302         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3303          MPI_ROTAT2(lensend),inext,7700+isend,&
3304          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3305          iprev,7700+irecv,FG_COMM,status,IERR)
3306 !        write (iout,*) "Gather PRECOMP21"
3307 !        call flush(iout)
3308         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3309          MPI_PRECOMP22(lensend),inext,8800+isend,&
3310          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3311          iprev,8800+irecv,FG_COMM,status,IERR)
3312 !        write (iout,*) "Gather PRECOMP22"
3313 !        call flush(iout)
3314         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3315          MPI_PRECOMP23(lensend),inext,9900+isend,&
3316          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3317          MPI_PRECOMP23(lenrecv),&
3318          iprev,9900+irecv,FG_COMM,status,IERR)
3319 !        write (iout,*) "Gather PRECOMP23"
3320 !        call flush(iout)
3321         endif
3322         isend=irecv
3323         irecv=irecv-1
3324         if (irecv.lt.0) irecv=nfgtasks1-1
3325       enddo
3326 #endif
3327         time_gather=time_gather+MPI_Wtime()-time00
3328       endif
3329 #ifdef DEBUG
3330 !      if (fg_rank.eq.0) then
3331         write (iout,*) "Arrays UG and UGDER"
3332         do i=1,nres-1
3333           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3334            ((ug(l,k,i),l=1,2),k=1,2),&
3335            ((ugder(l,k,i),l=1,2),k=1,2)
3336         enddo
3337         write (iout,*) "Arrays UG2 and UG2DER"
3338         do i=1,nres-1
3339           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3340            ((ug2(l,k,i),l=1,2),k=1,2),&
3341            ((ug2der(l,k,i),l=1,2),k=1,2)
3342         enddo
3343         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3344         do i=1,nres-1
3345           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3346            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3347            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3348         enddo
3349         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3350         do i=1,nres-1
3351           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3352            costab(i),sintab(i),costab2(i),sintab2(i)
3353         enddo
3354         write (iout,*) "Array MUDER"
3355         do i=1,nres-1
3356           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3357         enddo
3358 !      endif
3359 #endif
3360 #endif
3361 !d      do i=1,nres
3362 !d        iti = itortyp(itype(i,1))
3363 !d        write (iout,*) i
3364 !d        do j=1,2
3365 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3366 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3367 !d        enddo
3368 !d      enddo
3369       return
3370       end subroutine set_matrices
3371 !-----------------------------------------------------------------------------
3372       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3373 !
3374 ! This subroutine calculates the average interaction energy and its gradient
3375 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3376 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3377 ! The potential depends both on the distance of peptide-group centers and on
3378 ! the orientation of the CA-CA virtual bonds.
3379 !
3380       use comm_locel
3381 !      implicit real*8 (a-h,o-z)
3382 #ifdef MPI
3383       include 'mpif.h'
3384 #endif
3385 !      include 'DIMENSIONS'
3386 !      include 'COMMON.CONTROL'
3387 !      include 'COMMON.SETUP'
3388 !      include 'COMMON.IOUNITS'
3389 !      include 'COMMON.GEO'
3390 !      include 'COMMON.VAR'
3391 !      include 'COMMON.LOCAL'
3392 !      include 'COMMON.CHAIN'
3393 !      include 'COMMON.DERIV'
3394 !      include 'COMMON.INTERACT'
3395 !      include 'COMMON.CONTACTS'
3396 !      include 'COMMON.TORSION'
3397 !      include 'COMMON.VECTORS'
3398 !      include 'COMMON.FFIELD'
3399 !      include 'COMMON.TIME1'
3400       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3401       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3402       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3403 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3404       real(kind=8),dimension(4) :: muij
3405 !el      integer :: num_conti,j1,j2
3406 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3407 !el        dz_normi,xmedi,ymedi,zmedi
3408
3409 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3410 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3411 !el          num_conti,j1,j2
3412
3413 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3414 #ifdef MOMENT
3415       real(kind=8) :: scal_el=1.0d0
3416 #else
3417       real(kind=8) :: scal_el=0.5d0
3418 #endif
3419 ! 12/13/98
3420 ! 13-go grudnia roku pamietnego...
3421       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3422                                              0.0d0,1.0d0,0.0d0,&
3423                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3424 !el local variables
3425       integer :: i,k,j,icont
3426       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3427       real(kind=8) :: fac,t_eelecij,fracinbuf
3428
3429
3430 !d      write(iout,*) 'In EELEC'
3431 !        print *,"IN EELEC"
3432 !d      do i=1,nloctyp
3433 !d        write(iout,*) 'Type',i
3434 !d        write(iout,*) 'B1',B1(:,i)
3435 !d        write(iout,*) 'B2',B2(:,i)
3436 !d        write(iout,*) 'CC',CC(:,:,i)
3437 !d        write(iout,*) 'DD',DD(:,:,i)
3438 !d        write(iout,*) 'EE',EE(:,:,i)
3439 !d      enddo
3440 !d      call check_vecgrad
3441 !d      stop
3442 !      ees=0.0d0  !AS
3443 !      evdw1=0.0d0
3444 !      eel_loc=0.0d0
3445 !      eello_turn3=0.0d0
3446 !      eello_turn4=0.0d0
3447       t_eelecij=0.0d0
3448       ees=0.0D0
3449       evdw1=0.0D0
3450       eel_loc=0.0d0
3451       eello_turn3=0.0d0
3452       eello_turn4=0.0d0
3453       if (nres_molec(1).eq.0) return
3454 !
3455
3456       if (icheckgrad.eq.1) then
3457 !el
3458 !        do i=0,2*nres+2
3459 !          dc_norm(1,i)=0.0d0
3460 !          dc_norm(2,i)=0.0d0
3461 !          dc_norm(3,i)=0.0d0
3462 !        enddo
3463         do i=1,nres-1
3464           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3465           do k=1,3
3466             dc_norm(k,i)=dc(k,i)*fac
3467           enddo
3468 !          write (iout,*) 'i',i,' fac',fac
3469         enddo
3470       endif
3471 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3472 !        wturn6
3473       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3474           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3475           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3476 !        call vec_and_deriv
3477 #ifdef TIMING
3478         time01=MPI_Wtime()
3479 #endif
3480 !        print *, "before set matrices"
3481         call set_matrices
3482 !        print *, "after set matrices"
3483
3484 #ifdef TIMING
3485         time_mat=time_mat+MPI_Wtime()-time01
3486 #endif
3487       endif
3488 !       print *, "after set matrices"
3489 !d      do i=1,nres-1
3490 !d        write (iout,*) 'i=',i
3491 !d        do k=1,3
3492 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3493 !d        enddo
3494 !d        do k=1,3
3495 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3496 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3497 !d        enddo
3498 !d      enddo
3499       t_eelecij=0.0d0
3500       ees=0.0D0
3501       evdw1=0.0D0
3502       eel_loc=0.0d0
3503       eello_turn3=0.0d0
3504       eello_turn4=0.0d0
3505 !el      ind=0
3506       do i=1,nres
3507         num_cont_hb(i)=0
3508       enddo
3509 !d      print '(a)','Enter EELEC'
3510 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3511 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3512 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3513       do i=1,nres
3514         gel_loc_loc(i)=0.0d0
3515         gcorr_loc(i)=0.0d0
3516       enddo
3517 !
3518 !
3519 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3520 !
3521 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3522 !
3523
3524
3525 !        print *,"before iturn3 loop"
3526       do i=iturn3_start,iturn3_end
3527         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3528         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3529         dxi=dc(1,i)
3530         dyi=dc(2,i)
3531         dzi=dc(3,i)
3532         dx_normi=dc_norm(1,i)
3533         dy_normi=dc_norm(2,i)
3534         dz_normi=dc_norm(3,i)
3535         xmedi=c(1,i)+0.5d0*dxi
3536         ymedi=c(2,i)+0.5d0*dyi
3537         zmedi=c(3,i)+0.5d0*dzi
3538         call to_box(xmedi,ymedi,zmedi)
3539         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3540         num_conti=0
3541        call eelecij(i,i+2,ees,evdw1,eel_loc)
3542         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3543         num_cont_hb(i)=num_conti
3544       enddo
3545       do i=iturn4_start,iturn4_end
3546         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3547           .or. itype(i+3,1).eq.ntyp1 &
3548           .or. itype(i+4,1).eq.ntyp1) cycle
3549 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3550         dxi=dc(1,i)
3551         dyi=dc(2,i)
3552         dzi=dc(3,i)
3553         dx_normi=dc_norm(1,i)
3554         dy_normi=dc_norm(2,i)
3555         dz_normi=dc_norm(3,i)
3556         xmedi=c(1,i)+0.5d0*dxi
3557         ymedi=c(2,i)+0.5d0*dyi
3558         zmedi=c(3,i)+0.5d0*dzi
3559         call to_box(xmedi,ymedi,zmedi)
3560         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3561         num_conti=num_cont_hb(i)
3562         call eelecij(i,i+3,ees,evdw1,eel_loc)
3563         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3564         call eturn4(i,eello_turn4)
3565 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3566         num_cont_hb(i)=num_conti
3567       enddo   ! i
3568 !
3569 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3570 !
3571 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3572 !      do i=iatel_s,iatel_e
3573 ! JPRDLC
3574        do icont=g_listpp_start,g_listpp_end
3575         i=newcontlistppi(icont)
3576         j=newcontlistppj(icont)
3577         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3578         dxi=dc(1,i)
3579         dyi=dc(2,i)
3580         dzi=dc(3,i)
3581         dx_normi=dc_norm(1,i)
3582         dy_normi=dc_norm(2,i)
3583         dz_normi=dc_norm(3,i)
3584         xmedi=c(1,i)+0.5d0*dxi
3585         ymedi=c(2,i)+0.5d0*dyi
3586         zmedi=c(3,i)+0.5d0*dzi
3587         call to_box(xmedi,ymedi,zmedi)
3588         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3589
3590 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3591         num_conti=num_cont_hb(i)
3592 !        do j=ielstart(i),ielend(i)
3593 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3594           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3595           call eelecij(i,j,ees,evdw1,eel_loc)
3596 !        enddo ! j
3597         num_cont_hb(i)=num_conti
3598       enddo   ! i
3599 !      write (iout,*) "Number of loop steps in EELEC:",ind
3600 !d      do i=1,nres
3601 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3602 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3603 !d      enddo
3604 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3605 !cc      eel_loc=eel_loc+eello_turn3
3606 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3607       return
3608       end subroutine eelec
3609 !-----------------------------------------------------------------------------
3610       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3611
3612       use comm_locel
3613 !      implicit real*8 (a-h,o-z)
3614 !      include 'DIMENSIONS'
3615 #ifdef MPI
3616       include "mpif.h"
3617 #endif
3618 !      include 'COMMON.CONTROL'
3619 !      include 'COMMON.IOUNITS'
3620 !      include 'COMMON.GEO'
3621 !      include 'COMMON.VAR'
3622 !      include 'COMMON.LOCAL'
3623 !      include 'COMMON.CHAIN'
3624 !      include 'COMMON.DERIV'
3625 !      include 'COMMON.INTERACT'
3626 !      include 'COMMON.CONTACTS'
3627 !      include 'COMMON.TORSION'
3628 !      include 'COMMON.VECTORS'
3629 !      include 'COMMON.FFIELD'
3630 !      include 'COMMON.TIME1'
3631       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3632       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3633       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3634 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3635       real(kind=8),dimension(4) :: muij
3636       real(kind=8) :: geel_loc_ij,geel_loc_ji
3637       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3638                     dist_temp, dist_init,rlocshield,fracinbuf
3639       integer xshift,yshift,zshift,ilist,iresshield
3640 !el      integer :: num_conti,j1,j2
3641 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3642 !el        dz_normi,xmedi,ymedi,zmedi
3643
3644 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3645 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3646 !el          num_conti,j1,j2
3647
3648 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3649 #ifdef MOMENT
3650       real(kind=8) :: scal_el=1.0d0
3651 #else
3652       real(kind=8) :: scal_el=0.5d0
3653 #endif
3654 ! 12/13/98
3655 ! 13-go grudnia roku pamietnego...
3656       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3657                                              0.0d0,1.0d0,0.0d0,&
3658                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3659 !      integer :: maxconts=nres/4
3660 !el local variables
3661       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3662       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3663       real(kind=8) ::  faclipij2, faclipij
3664       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3665       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3666                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3667                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3668                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3669                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3670                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3671                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3672                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3673 !      maxconts=nres/4
3674 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3675 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3676
3677 !          time00=MPI_Wtime()
3678 !d      write (iout,*) "eelecij",i,j
3679 !          ind=ind+1
3680           iteli=itel(i)
3681           itelj=itel(j)
3682           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3683           aaa=app(iteli,itelj)
3684           bbb=bpp(iteli,itelj)
3685           ael6i=ael6(iteli,itelj)
3686           ael3i=ael3(iteli,itelj)
3687           dxj=dc(1,j)
3688           dyj=dc(2,j)
3689           dzj=dc(3,j)
3690           dx_normj=dc_norm(1,j)
3691           dy_normj=dc_norm(2,j)
3692           dz_normj=dc_norm(3,j)
3693 !          xj=c(1,j)+0.5D0*dxj-xmedi
3694 !          yj=c(2,j)+0.5D0*dyj-ymedi
3695 !          zj=c(3,j)+0.5D0*dzj-zmedi
3696           xj=c(1,j)+0.5D0*dxj
3697           yj=c(2,j)+0.5D0*dyj
3698           zj=c(3,j)+0.5D0*dzj
3699
3700           call to_box(xj,yj,zj)
3701           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3702           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3703           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3704           xj=boxshift(xj-xmedi,boxxsize)
3705           yj=boxshift(yj-ymedi,boxysize)
3706           zj=boxshift(zj-zmedi,boxzsize)
3707
3708           rij=xj*xj+yj*yj+zj*zj
3709           rrmij=1.0D0/rij
3710           rij=dsqrt(rij)
3711 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3712             sss_ele_cut=sscale_ele(rij)
3713             sss_ele_grad=sscagrad_ele(rij)
3714 !             sss_ele_cut=1.0d0
3715 !             sss_ele_grad=0.0d0
3716 !            print *,sss_ele_cut,sss_ele_grad,&
3717 !            (rij),r_cut_ele,rlamb_ele
3718             if (sss_ele_cut.le.0.0) go to 128
3719
3720           rmij=1.0D0/rij
3721           r3ij=rrmij*rmij
3722           r6ij=r3ij*r3ij
3723           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3724           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3725           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3726           fac=cosa-3.0D0*cosb*cosg
3727           ev1=aaa*r6ij*r6ij
3728 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3729           if (j.eq.i+2) ev1=scal_el*ev1
3730           ev2=bbb*r6ij
3731           fac3=ael6i*r6ij
3732           fac4=ael3i*r3ij
3733           evdwij=ev1+ev2
3734           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3735           el2=fac4*fac
3736 !          eesij=el1+el2
3737           if (shield_mode.gt.0) then
3738 !C          fac_shield(i)=0.4
3739 !C          fac_shield(j)=0.6
3740           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3741           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3742           eesij=(el1+el2)
3743           ees=ees+eesij*sss_ele_cut
3744 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3745 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3746           else
3747           fac_shield(i)=1.0
3748           fac_shield(j)=1.0
3749           eesij=(el1+el2)
3750           ees=ees+eesij   &
3751             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3752 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3753           endif
3754
3755 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3756           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3757 !          ees=ees+eesij*sss_ele_cut
3758           evdw1=evdw1+evdwij*sss_ele_cut  &
3759            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3760 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3761 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3762 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3763 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3764
3765           if (energy_dec) then
3766 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3767 !                  'evdw1',i,j,evdwij,&
3768 !                  iteli,itelj,aaa,evdw1
3769               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3770               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3771           endif
3772 !
3773 ! Calculate contributions to the Cartesian gradient.
3774 !
3775 #ifdef SPLITELE
3776           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3777               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3778           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3779              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3780           fac1=fac
3781           erij(1)=xj*rmij
3782           erij(2)=yj*rmij
3783           erij(3)=zj*rmij
3784 !
3785 ! Radial derivatives. First process both termini of the fragment (i,j)
3786 !
3787           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3788           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3789           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3790            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3791           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3792             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3793
3794           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3795           (shield_mode.gt.0)) then
3796 !C          print *,i,j
3797           do ilist=1,ishield_list(i)
3798            iresshield=shield_list(ilist,i)
3799            do k=1,3
3800            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3801            *2.0*sss_ele_cut
3802            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3803                    rlocshield &
3804             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3805             *sss_ele_cut
3806             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3807            enddo
3808           enddo
3809           do ilist=1,ishield_list(j)
3810            iresshield=shield_list(ilist,j)
3811            do k=1,3
3812            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3813           *2.0*sss_ele_cut
3814            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3815                    rlocshield &
3816            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3817            *sss_ele_cut
3818            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3819            enddo
3820           enddo
3821           do k=1,3
3822             gshieldc(k,i)=gshieldc(k,i)+ &
3823                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3824            *sss_ele_cut
3825
3826             gshieldc(k,j)=gshieldc(k,j)+ &
3827                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3828            *sss_ele_cut
3829
3830             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3831                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3832            *sss_ele_cut
3833
3834             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3835                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3836            *sss_ele_cut
3837
3838            enddo
3839            endif
3840
3841
3842 !          do k=1,3
3843 !            ghalf=0.5D0*ggg(k)
3844 !            gelc(k,i)=gelc(k,i)+ghalf
3845 !            gelc(k,j)=gelc(k,j)+ghalf
3846 !          enddo
3847 ! 9/28/08 AL Gradient compotents will be summed only at the end
3848           do k=1,3
3849             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3850             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3851           enddo
3852             gelc_long(3,j)=gelc_long(3,j)+  &
3853           ssgradlipj*eesij/2.0d0*lipscale**2&
3854            *sss_ele_cut
3855
3856             gelc_long(3,i)=gelc_long(3,i)+  &
3857           ssgradlipi*eesij/2.0d0*lipscale**2&
3858            *sss_ele_cut
3859
3860
3861 !
3862 ! Loop over residues i+1 thru j-1.
3863 !
3864 !grad          do k=i+1,j-1
3865 !grad            do l=1,3
3866 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3867 !grad            enddo
3868 !grad          enddo
3869           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3870            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3871           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3872            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3873           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3874            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3875
3876 !          do k=1,3
3877 !            ghalf=0.5D0*ggg(k)
3878 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3879 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3880 !          enddo
3881 ! 9/28/08 AL Gradient compotents will be summed only at the end
3882           do k=1,3
3883             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3884             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3885           enddo
3886
3887 !C Lipidic part for scaling weight
3888            gvdwpp(3,j)=gvdwpp(3,j)+ &
3889           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3890            gvdwpp(3,i)=gvdwpp(3,i)+ &
3891           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3892 !! Loop over residues i+1 thru j-1.
3893 !
3894 !grad          do k=i+1,j-1
3895 !grad            do l=1,3
3896 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3897 !grad            enddo
3898 !grad          enddo
3899 #else
3900           facvdw=(ev1+evdwij)*sss_ele_cut &
3901            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3902
3903           facel=(el1+eesij)*sss_ele_cut
3904           fac1=fac
3905           fac=-3*rrmij*(facvdw+facvdw+facel)
3906           erij(1)=xj*rmij
3907           erij(2)=yj*rmij
3908           erij(3)=zj*rmij
3909 !
3910 ! Radial derivatives. First process both termini of the fragment (i,j)
3911 !
3912           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3913           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3914           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3915 !          do k=1,3
3916 !            ghalf=0.5D0*ggg(k)
3917 !            gelc(k,i)=gelc(k,i)+ghalf
3918 !            gelc(k,j)=gelc(k,j)+ghalf
3919 !          enddo
3920 ! 9/28/08 AL Gradient compotents will be summed only at the end
3921           do k=1,3
3922             gelc_long(k,j)=gelc(k,j)+ggg(k)
3923             gelc_long(k,i)=gelc(k,i)-ggg(k)
3924           enddo
3925 !
3926 ! Loop over residues i+1 thru j-1.
3927 !
3928 !grad          do k=i+1,j-1
3929 !grad            do l=1,3
3930 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3931 !grad            enddo
3932 !grad          enddo
3933 ! 9/28/08 AL Gradient compotents will be summed only at the end
3934           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3935            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3936           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3937            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3938           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3939            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3940
3941           do k=1,3
3942             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3943             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3944           enddo
3945            gvdwpp(3,j)=gvdwpp(3,j)+ &
3946           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3947            gvdwpp(3,i)=gvdwpp(3,i)+ &
3948           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3949
3950 #endif
3951 !
3952 ! Angular part
3953 !
3954           ecosa=2.0D0*fac3*fac1+fac4
3955           fac4=-3.0D0*fac4
3956           fac3=-6.0D0*fac3
3957           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3958           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3959           do k=1,3
3960             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3961             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3962           enddo
3963 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3964 !d   &          (dcosg(k),k=1,3)
3965           do k=1,3
3966             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3967              *fac_shield(i)**2*fac_shield(j)**2 &
3968              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3969
3970           enddo
3971 !          do k=1,3
3972 !            ghalf=0.5D0*ggg(k)
3973 !            gelc(k,i)=gelc(k,i)+ghalf
3974 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3975 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3976 !            gelc(k,j)=gelc(k,j)+ghalf
3977 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3978 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3979 !          enddo
3980 !grad          do k=i+1,j-1
3981 !grad            do l=1,3
3982 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3983 !grad            enddo
3984 !grad          enddo
3985           do k=1,3
3986             gelc(k,i)=gelc(k,i) &
3987                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3988                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3989                      *sss_ele_cut &
3990                      *fac_shield(i)**2*fac_shield(j)**2 &
3991                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3992
3993             gelc(k,j)=gelc(k,j) &
3994                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3995                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3996                      *sss_ele_cut  &
3997                      *fac_shield(i)**2*fac_shield(j)**2  &
3998                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3999
4000             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4001             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4002           enddo
4003
4004           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4005               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4006               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4007 !
4008 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4009 !   energy of a peptide unit is assumed in the form of a second-order
4010 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4011 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4012 !   are computed for EVERY pair of non-contiguous peptide groups.
4013 !
4014           if (j.lt.nres-1) then
4015             j1=j+1
4016             j2=j-1
4017           else
4018             j1=j-1
4019             j2=j-2
4020           endif
4021           kkk=0
4022           do k=1,2
4023             do l=1,2
4024               kkk=kkk+1
4025               muij(kkk)=mu(k,i)*mu(l,j)
4026 #ifdef NEWCORR
4027              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4028 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4029              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4030              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4031 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4032              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4033 #endif
4034
4035             enddo
4036           enddo
4037 !d         write (iout,*) 'EELEC: i',i,' j',j
4038 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4039 !d          write(iout,*) 'muij',muij
4040           ury=scalar(uy(1,i),erij)
4041           urz=scalar(uz(1,i),erij)
4042           vry=scalar(uy(1,j),erij)
4043           vrz=scalar(uz(1,j),erij)
4044           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4045           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4046           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4047           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4048           fac=dsqrt(-ael6i)*r3ij
4049           a22=a22*fac
4050           a23=a23*fac
4051           a32=a32*fac
4052           a33=a33*fac
4053 !d          write (iout,'(4i5,4f10.5)')
4054 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4055 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4056 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4057 !d     &      uy(:,j),uz(:,j)
4058 !d          write (iout,'(4f10.5)')
4059 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4060 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4061 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4062 !d           write (iout,'(9f10.5/)')
4063 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4064 ! Derivatives of the elements of A in virtual-bond vectors
4065           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4066           do k=1,3
4067             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4068             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4069             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4070             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4071             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4072             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4073             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4074             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4075             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4076             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4077             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4078             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4079           enddo
4080 ! Compute radial contributions to the gradient
4081           facr=-3.0d0*rrmij
4082           a22der=a22*facr
4083           a23der=a23*facr
4084           a32der=a32*facr
4085           a33der=a33*facr
4086           agg(1,1)=a22der*xj
4087           agg(2,1)=a22der*yj
4088           agg(3,1)=a22der*zj
4089           agg(1,2)=a23der*xj
4090           agg(2,2)=a23der*yj
4091           agg(3,2)=a23der*zj
4092           agg(1,3)=a32der*xj
4093           agg(2,3)=a32der*yj
4094           agg(3,3)=a32der*zj
4095           agg(1,4)=a33der*xj
4096           agg(2,4)=a33der*yj
4097           agg(3,4)=a33der*zj
4098 ! Add the contributions coming from er
4099           fac3=-3.0d0*fac
4100           do k=1,3
4101             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4102             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4103             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4104             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4105           enddo
4106           do k=1,3
4107 ! Derivatives in DC(i)
4108 !grad            ghalf1=0.5d0*agg(k,1)
4109 !grad            ghalf2=0.5d0*agg(k,2)
4110 !grad            ghalf3=0.5d0*agg(k,3)
4111 !grad            ghalf4=0.5d0*agg(k,4)
4112             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4113             -3.0d0*uryg(k,2)*vry)!+ghalf1
4114             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4115             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4116             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4117             -3.0d0*urzg(k,2)*vry)!+ghalf3
4118             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4119             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4120 ! Derivatives in DC(i+1)
4121             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4122             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4123             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4124             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4125             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4126             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4127             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4128             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4129 ! Derivatives in DC(j)
4130             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4131             -3.0d0*vryg(k,2)*ury)!+ghalf1
4132             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4133             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4134             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4135             -3.0d0*vryg(k,2)*urz)!+ghalf3
4136             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4137             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4138 ! Derivatives in DC(j+1) or DC(nres-1)
4139             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4140             -3.0d0*vryg(k,3)*ury)
4141             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4142             -3.0d0*vrzg(k,3)*ury)
4143             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4144             -3.0d0*vryg(k,3)*urz)
4145             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4146             -3.0d0*vrzg(k,3)*urz)
4147 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4148 !grad              do l=1,4
4149 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4150 !grad              enddo
4151 !grad            endif
4152           enddo
4153           acipa(1,1)=a22
4154           acipa(1,2)=a23
4155           acipa(2,1)=a32
4156           acipa(2,2)=a33
4157           a22=-a22
4158           a23=-a23
4159           do l=1,2
4160             do k=1,3
4161               agg(k,l)=-agg(k,l)
4162               aggi(k,l)=-aggi(k,l)
4163               aggi1(k,l)=-aggi1(k,l)
4164               aggj(k,l)=-aggj(k,l)
4165               aggj1(k,l)=-aggj1(k,l)
4166             enddo
4167           enddo
4168           if (j.lt.nres-1) then
4169             a22=-a22
4170             a32=-a32
4171             do l=1,3,2
4172               do k=1,3
4173                 agg(k,l)=-agg(k,l)
4174                 aggi(k,l)=-aggi(k,l)
4175                 aggi1(k,l)=-aggi1(k,l)
4176                 aggj(k,l)=-aggj(k,l)
4177                 aggj1(k,l)=-aggj1(k,l)
4178               enddo
4179             enddo
4180           else
4181             a22=-a22
4182             a23=-a23
4183             a32=-a32
4184             a33=-a33
4185             do l=1,4
4186               do k=1,3
4187                 agg(k,l)=-agg(k,l)
4188                 aggi(k,l)=-aggi(k,l)
4189                 aggi1(k,l)=-aggi1(k,l)
4190                 aggj(k,l)=-aggj(k,l)
4191                 aggj1(k,l)=-aggj1(k,l)
4192               enddo
4193             enddo
4194           endif
4195           ENDIF ! WCORR
4196           IF (wel_loc.gt.0.0d0) THEN
4197 ! Contribution to the local-electrostatic energy coming from the i-j pair
4198           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4199            +a33*muij(4)
4200           if (shield_mode.eq.0) then
4201            fac_shield(i)=1.0
4202            fac_shield(j)=1.0
4203           endif
4204           eel_loc_ij=eel_loc_ij &
4205          *fac_shield(i)*fac_shield(j) &
4206          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4207 !C Now derivative over eel_loc
4208           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4209          (shield_mode.gt.0)) then
4210 !C          print *,i,j
4211
4212           do ilist=1,ishield_list(i)
4213            iresshield=shield_list(ilist,i)
4214            do k=1,3
4215            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4216                                                 /fac_shield(i)&
4217            *sss_ele_cut
4218            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4219                    rlocshield  &
4220           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4221           *sss_ele_cut
4222
4223             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4224            +rlocshield
4225            enddo
4226           enddo
4227           do ilist=1,ishield_list(j)
4228            iresshield=shield_list(ilist,j)
4229            do k=1,3
4230            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4231                                             /fac_shield(j)   &
4232             *sss_ele_cut
4233            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4234                    rlocshield  &
4235       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4236        *sss_ele_cut
4237
4238            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4239                   +rlocshield
4240
4241            enddo
4242           enddo
4243
4244           do k=1,3
4245             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4246                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4247                     *sss_ele_cut
4248             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4249                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4250                     *sss_ele_cut
4251             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4252                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4253                     *sss_ele_cut
4254             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4255                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4256                     *sss_ele_cut
4257
4258            enddo
4259            endif
4260
4261 #ifdef NEWCORR
4262          geel_loc_ij=(a22*gmuij1(1)&
4263           +a23*gmuij1(2)&
4264           +a32*gmuij1(3)&
4265           +a33*gmuij1(4))&
4266          *fac_shield(i)*fac_shield(j)&
4267                     *sss_ele_cut     &
4268          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4269
4270
4271 !c         write(iout,*) "derivative over thatai"
4272 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4273 !c     &   a33*gmuij1(4)
4274          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4275            geel_loc_ij*wel_loc
4276 !c         write(iout,*) "derivative over thatai-1"
4277 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4278 !c     &   a33*gmuij2(4)
4279          geel_loc_ij=&
4280           a22*gmuij2(1)&
4281           +a23*gmuij2(2)&
4282           +a32*gmuij2(3)&
4283           +a33*gmuij2(4)
4284          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4285            geel_loc_ij*wel_loc&
4286          *fac_shield(i)*fac_shield(j)&
4287                     *sss_ele_cut &
4288          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4289
4290
4291 !c  Derivative over j residue
4292          geel_loc_ji=a22*gmuji1(1)&
4293           +a23*gmuji1(2)&
4294           +a32*gmuji1(3)&
4295           +a33*gmuji1(4)
4296 !c         write(iout,*) "derivative over thataj"
4297 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4298 !c     &   a33*gmuji1(4)
4299
4300         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4301            geel_loc_ji*wel_loc&
4302          *fac_shield(i)*fac_shield(j)&
4303                     *sss_ele_cut &
4304          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4305
4306
4307          geel_loc_ji=&
4308           +a22*gmuji2(1)&
4309           +a23*gmuji2(2)&
4310           +a32*gmuji2(3)&
4311           +a33*gmuji2(4)
4312 !c         write(iout,*) "derivative over thataj-1"
4313 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4314 !c     &   a33*gmuji2(4)
4315          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4316            geel_loc_ji*wel_loc&
4317          *fac_shield(i)*fac_shield(j)&
4318                     *sss_ele_cut &
4319          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4320
4321 #endif
4322
4323 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4324 !           eel_loc_ij=0.0
4325 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4326 !                  'eelloc',i,j,eel_loc_ij
4327           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4328                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4329 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4330
4331 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4332 !          if (energy_dec) write (iout,*) "muij",muij
4333 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4334
4335           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4336 ! Partial derivatives in virtual-bond dihedral angles gamma
4337           if (i.gt.1) &
4338           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4339                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4340                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4341                  *sss_ele_cut  &
4342           *fac_shield(i)*fac_shield(j) &
4343           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4344
4345           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4346                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4347                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4348                  *sss_ele_cut &
4349           *fac_shield(i)*fac_shield(j) &
4350           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4351 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4352 !          do l=1,3
4353 !            ggg(1)=(agg(1,1)*muij(1)+ &
4354 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4355 !            *sss_ele_cut &
4356 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4357 !            ggg(2)=(agg(2,1)*muij(1)+ &
4358 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4359 !            *sss_ele_cut &
4360 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4361 !            ggg(3)=(agg(3,1)*muij(1)+ &
4362 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4363 !            *sss_ele_cut &
4364 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4365            xtemp(1)=xj
4366            xtemp(2)=yj
4367            xtemp(3)=zj
4368
4369            do l=1,3
4370             ggg(l)=(agg(l,1)*muij(1)+ &
4371                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4372             *sss_ele_cut &
4373           *fac_shield(i)*fac_shield(j) &
4374           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4375              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4376
4377
4378             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4379             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4380 !grad            ghalf=0.5d0*ggg(l)
4381 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4382 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4383           enddo
4384             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4385           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4386           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4387
4388             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4389           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4390           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4391
4392 !grad          do k=i+1,j2
4393 !grad            do l=1,3
4394 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4395 !grad            enddo
4396 !grad          enddo
4397 ! Remaining derivatives of eello
4398           do l=1,3
4399             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4400                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4401             *sss_ele_cut &
4402           *fac_shield(i)*fac_shield(j) &
4403           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4404
4405 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4406             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4407                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4408             +aggi1(l,4)*muij(4))&
4409             *sss_ele_cut &
4410           *fac_shield(i)*fac_shield(j) &
4411           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4412
4413 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4414             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4415                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4416             *sss_ele_cut &
4417           *fac_shield(i)*fac_shield(j) &
4418           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4419
4420 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4421             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4422                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4423             +aggj1(l,4)*muij(4))&
4424             *sss_ele_cut &
4425           *fac_shield(i)*fac_shield(j) &
4426          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4427
4428 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4429           enddo
4430           ENDIF
4431 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4432 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4433           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4434              .and. num_conti.le.maxconts) then
4435 !            write (iout,*) i,j," entered corr"
4436 !
4437 ! Calculate the contact function. The ith column of the array JCONT will
4438 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4439 ! greater than I). The arrays FACONT and GACONT will contain the values of
4440 ! the contact function and its derivative.
4441 !           r0ij=1.02D0*rpp(iteli,itelj)
4442 !           r0ij=1.11D0*rpp(iteli,itelj)
4443             r0ij=2.20D0*rpp(iteli,itelj)
4444 !           r0ij=1.55D0*rpp(iteli,itelj)
4445             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4446 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4447             if (fcont.gt.0.0D0) then
4448               num_conti=num_conti+1
4449               if (num_conti.gt.maxconts) then
4450 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4451 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4452                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4453                                ' will skip next contacts for this conf.', num_conti
4454               else
4455                 jcont_hb(num_conti,i)=j
4456 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4457 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4458                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4459                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4460 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4461 !  terms.
4462                 d_cont(num_conti,i)=rij
4463 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4464 !     --- Electrostatic-interaction matrix ---
4465                 a_chuj(1,1,num_conti,i)=a22
4466                 a_chuj(1,2,num_conti,i)=a23
4467                 a_chuj(2,1,num_conti,i)=a32
4468                 a_chuj(2,2,num_conti,i)=a33
4469 !     --- Gradient of rij
4470                 do kkk=1,3
4471                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4472                 enddo
4473                 kkll=0
4474                 do k=1,2
4475                   do l=1,2
4476                     kkll=kkll+1
4477                     do m=1,3
4478                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4479                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4480                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4481                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4482                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4483                     enddo
4484                   enddo
4485                 enddo
4486                 ENDIF
4487                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4488 ! Calculate contact energies
4489                 cosa4=4.0D0*cosa
4490                 wij=cosa-3.0D0*cosb*cosg
4491                 cosbg1=cosb+cosg
4492                 cosbg2=cosb-cosg
4493 !               fac3=dsqrt(-ael6i)/r0ij**3
4494                 fac3=dsqrt(-ael6i)*r3ij
4495 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4496                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4497                 if (ees0tmp.gt.0) then
4498                   ees0pij=dsqrt(ees0tmp)
4499                 else
4500                   ees0pij=0
4501                 endif
4502                 if (shield_mode.eq.0) then
4503                 fac_shield(i)=1.0d0
4504                 fac_shield(j)=1.0d0
4505                 else
4506                 ees0plist(num_conti,i)=j
4507                 endif
4508 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4509                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4510                 if (ees0tmp.gt.0) then
4511                   ees0mij=dsqrt(ees0tmp)
4512                 else
4513                   ees0mij=0
4514                 endif
4515 !               ees0mij=0.0D0
4516                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4517                      *sss_ele_cut &
4518                      *fac_shield(i)*fac_shield(j)
4519 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4520
4521                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4522                      *sss_ele_cut &
4523                      *fac_shield(i)*fac_shield(j)
4524 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4525
4526 ! Diagnostics. Comment out or remove after debugging!
4527 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4528 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4529 !               ees0m(num_conti,i)=0.0D0
4530 ! End diagnostics.
4531 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4532 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4533 ! Angular derivatives of the contact function
4534                 ees0pij1=fac3/ees0pij
4535                 ees0mij1=fac3/ees0mij
4536                 fac3p=-3.0D0*fac3*rrmij
4537                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4538                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4539 !               ees0mij1=0.0D0
4540                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4541                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4542                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4543                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4544                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4545                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4546                 ecosap=ecosa1+ecosa2
4547                 ecosbp=ecosb1+ecosb2
4548                 ecosgp=ecosg1+ecosg2
4549                 ecosam=ecosa1-ecosa2
4550                 ecosbm=ecosb1-ecosb2
4551                 ecosgm=ecosg1-ecosg2
4552 ! Diagnostics
4553 !               ecosap=ecosa1
4554 !               ecosbp=ecosb1
4555 !               ecosgp=ecosg1
4556 !               ecosam=0.0D0
4557 !               ecosbm=0.0D0
4558 !               ecosgm=0.0D0
4559 ! End diagnostics
4560                 facont_hb(num_conti,i)=fcont
4561                 fprimcont=fprimcont/rij
4562 !d              facont_hb(num_conti,i)=1.0D0
4563 ! Following line is for diagnostics.
4564 !d              fprimcont=0.0D0
4565                 do k=1,3
4566                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4567                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4568                 enddo
4569                 do k=1,3
4570                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4571                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4572                 enddo
4573                 gggp(1)=gggp(1)+ees0pijp*xj &
4574                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4575                 gggp(2)=gggp(2)+ees0pijp*yj &
4576                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4577                 gggp(3)=gggp(3)+ees0pijp*zj &
4578                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4579
4580                 gggm(1)=gggm(1)+ees0mijp*xj &
4581                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4582
4583                 gggm(2)=gggm(2)+ees0mijp*yj &
4584                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4585
4586                 gggm(3)=gggm(3)+ees0mijp*zj &
4587                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4588
4589 ! Derivatives due to the contact function
4590                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4591                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4592                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4593                 do k=1,3
4594 !
4595 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4596 !          following the change of gradient-summation algorithm.
4597 !
4598 !grad                  ghalfp=0.5D0*gggp(k)
4599 !grad                  ghalfm=0.5D0*gggm(k)
4600                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4601                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4602                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4603                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4604 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4605
4606
4607                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4608                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4609                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4610                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4611 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4612
4613
4614                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4615                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4616 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4617
4618                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4619                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4620                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4621                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4622 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4623
4624                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4625                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4626                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4627                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4628 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4629
4630                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4631                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4632 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4633
4634                 enddo
4635 ! Diagnostics. Comment out or remove after debugging!
4636 !diag           do k=1,3
4637 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4638 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4639 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4640 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4641 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4642 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4643 !diag           enddo
4644               ENDIF ! wcorr
4645               endif  ! num_conti.le.maxconts
4646             endif  ! fcont.gt.0
4647           endif    ! j.gt.i+1
4648           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4649             do k=1,4
4650               do l=1,3
4651                 ghalf=0.5d0*agg(l,k)
4652                 aggi(l,k)=aggi(l,k)+ghalf
4653                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4654                 aggj(l,k)=aggj(l,k)+ghalf
4655               enddo
4656             enddo
4657             if (j.eq.nres-1 .and. i.lt.j-2) then
4658               do k=1,4
4659                 do l=1,3
4660                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4661                 enddo
4662               enddo
4663             endif
4664           endif
4665  128  continue
4666 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4667       return
4668       end subroutine eelecij
4669 !-----------------------------------------------------------------------------
4670       subroutine eturn3(i,eello_turn3)
4671 ! Third- and fourth-order contributions from turns
4672
4673       use comm_locel
4674 !      implicit real*8 (a-h,o-z)
4675 !      include 'DIMENSIONS'
4676 !      include 'COMMON.IOUNITS'
4677 !      include 'COMMON.GEO'
4678 !      include 'COMMON.VAR'
4679 !      include 'COMMON.LOCAL'
4680 !      include 'COMMON.CHAIN'
4681 !      include 'COMMON.DERIV'
4682 !      include 'COMMON.INTERACT'
4683 !      include 'COMMON.CONTACTS'
4684 !      include 'COMMON.TORSION'
4685 !      include 'COMMON.VECTORS'
4686 !      include 'COMMON.FFIELD'
4687 !      include 'COMMON.CONTROL'
4688       real(kind=8),dimension(3) :: ggg
4689       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4690         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4691        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4692
4693       real(kind=8),dimension(2) :: auxvec,auxvec1
4694 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4695       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4696 !el      integer :: num_conti,j1,j2
4697 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4698 !el        dz_normi,xmedi,ymedi,zmedi
4699
4700 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4701 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4702 !el         num_conti,j1,j2
4703 !el local variables
4704       integer :: i,j,l,k,ilist,iresshield
4705       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4706       xj=0.0d0
4707       yj=0.0d0
4708       j=i+2
4709 !      write (iout,*) "eturn3",i,j,j1,j2
4710           zj=(c(3,j)+c(3,j+1))/2.0d0
4711             call to_box(xj,yj,zj)
4712             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4713
4714       a_temp(1,1)=a22
4715       a_temp(1,2)=a23
4716       a_temp(2,1)=a32
4717       a_temp(2,2)=a33
4718 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4719 !
4720 !               Third-order contributions
4721 !
4722 !                 (i+2)o----(i+3)
4723 !                      | |
4724 !                      | |
4725 !                 (i+1)o----i
4726 !
4727 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4728 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4729         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4730         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4731         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4732         call transpose2(auxmat(1,1),auxmat1(1,1))
4733         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4734         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4735         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4736         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4737         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4738
4739         if (shield_mode.eq.0) then
4740         fac_shield(i)=1.0d0
4741         fac_shield(j)=1.0d0
4742         endif
4743
4744         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4745          *fac_shield(i)*fac_shield(j)  &
4746          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4747         eello_t3= &
4748         0.5d0*(pizda(1,1)+pizda(2,2)) &
4749         *fac_shield(i)*fac_shield(j)
4750
4751         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4752                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4753 !C#ifdef NEWCORR
4754 !C Derivatives in theta
4755         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4756        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4757         *fac_shield(i)*fac_shield(j) &
4758         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4759
4760         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4761        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4762         *fac_shield(i)*fac_shield(j) &
4763         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4764
4765
4766 !C#endif
4767
4768
4769
4770           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4771        (shield_mode.gt.0)) then
4772 !C          print *,i,j
4773
4774           do ilist=1,ishield_list(i)
4775            iresshield=shield_list(ilist,i)
4776            do k=1,3
4777            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4778            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4779                    rlocshield &
4780            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4781             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4782              +rlocshield
4783            enddo
4784           enddo
4785           do ilist=1,ishield_list(j)
4786            iresshield=shield_list(ilist,j)
4787            do k=1,3
4788            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4789            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4790                    rlocshield &
4791            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4792            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4793                   +rlocshield
4794
4795            enddo
4796           enddo
4797
4798           do k=1,3
4799             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4800                    grad_shield(k,i)*eello_t3/fac_shield(i)
4801             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4802                    grad_shield(k,j)*eello_t3/fac_shield(j)
4803             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4804                    grad_shield(k,i)*eello_t3/fac_shield(i)
4805             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4806                    grad_shield(k,j)*eello_t3/fac_shield(j)
4807            enddo
4808            endif
4809
4810 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4811 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4812 !d     &    ' eello_turn3_num',4*eello_turn3_num
4813 ! Derivatives in gamma(i)
4814         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4815         call transpose2(auxmat2(1,1),auxmat3(1,1))
4816         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4817         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4818           *fac_shield(i)*fac_shield(j)        &
4819           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4820 ! Derivatives in gamma(i+1)
4821         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4822         call transpose2(auxmat2(1,1),auxmat3(1,1))
4823         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4824         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4825           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4826           *fac_shield(i)*fac_shield(j)        &
4827           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4828
4829 ! Cartesian derivatives
4830         do l=1,3
4831 !            ghalf1=0.5d0*agg(l,1)
4832 !            ghalf2=0.5d0*agg(l,2)
4833 !            ghalf3=0.5d0*agg(l,3)
4834 !            ghalf4=0.5d0*agg(l,4)
4835           a_temp(1,1)=aggi(l,1)!+ghalf1
4836           a_temp(1,2)=aggi(l,2)!+ghalf2
4837           a_temp(2,1)=aggi(l,3)!+ghalf3
4838           a_temp(2,2)=aggi(l,4)!+ghalf4
4839           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4840           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4841             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4842           *fac_shield(i)*fac_shield(j)      &
4843           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4844
4845           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4846           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4847           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4848           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4849           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4850           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4851             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4852           *fac_shield(i)*fac_shield(j)        &
4853           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4854
4855           a_temp(1,1)=aggj(l,1)!+ghalf1
4856           a_temp(1,2)=aggj(l,2)!+ghalf2
4857           a_temp(2,1)=aggj(l,3)!+ghalf3
4858           a_temp(2,2)=aggj(l,4)!+ghalf4
4859           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4860           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4861             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4862           *fac_shield(i)*fac_shield(j)      &
4863           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4864
4865           a_temp(1,1)=aggj1(l,1)
4866           a_temp(1,2)=aggj1(l,2)
4867           a_temp(2,1)=aggj1(l,3)
4868           a_temp(2,2)=aggj1(l,4)
4869           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4870           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4871             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4872           *fac_shield(i)*fac_shield(j)        &
4873           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4874         enddo
4875          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4876           ssgradlipi*eello_t3/4.0d0*lipscale
4877          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4878           ssgradlipj*eello_t3/4.0d0*lipscale
4879          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4880           ssgradlipi*eello_t3/4.0d0*lipscale
4881          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4882           ssgradlipj*eello_t3/4.0d0*lipscale
4883
4884       return
4885       end subroutine eturn3
4886 !-----------------------------------------------------------------------------
4887       subroutine eturn4(i,eello_turn4)
4888 ! Third- and fourth-order contributions from turns
4889
4890       use comm_locel
4891 !      implicit real*8 (a-h,o-z)
4892 !      include 'DIMENSIONS'
4893 !      include 'COMMON.IOUNITS'
4894 !      include 'COMMON.GEO'
4895 !      include 'COMMON.VAR'
4896 !      include 'COMMON.LOCAL'
4897 !      include 'COMMON.CHAIN'
4898 !      include 'COMMON.DERIV'
4899 !      include 'COMMON.INTERACT'
4900 !      include 'COMMON.CONTACTS'
4901 !      include 'COMMON.TORSION'
4902 !      include 'COMMON.VECTORS'
4903 !      include 'COMMON.FFIELD'
4904 !      include 'COMMON.CONTROL'
4905       real(kind=8),dimension(3) :: ggg
4906       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4907         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4908         gte1t,gte2t,gte3t,&
4909         gte1a,gtae3,gtae3e2, ae3gte2,&
4910         gtEpizda1,gtEpizda2,gtEpizda3
4911
4912       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4913        auxgEvec3,auxgvec
4914
4915 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4916       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4917 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4918 !el        dz_normi,xmedi,ymedi,zmedi
4919 !el      integer :: num_conti,j1,j2
4920 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4921 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4922 !el          num_conti,j1,j2
4923 !el local variables
4924       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4925       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4926          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4927       xj=0.0d0
4928       yj=0.0d0
4929       j=i+3
4930 !      if (j.ne.20) return
4931 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4932 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4933 !
4934 !               Fourth-order contributions
4935 !
4936 !                 (i+3)o----(i+4)
4937 !                     /  |
4938 !               (i+2)o   |
4939 !                     \  |
4940 !                 (i+1)o----i
4941 !
4942 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4943 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4944 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4945           zj=(c(3,j)+c(3,j+1))/2.0d0
4946             call to_box(xj,yj,zj)
4947             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4948
4949
4950         a_temp(1,1)=a22
4951         a_temp(1,2)=a23
4952         a_temp(2,1)=a32
4953         a_temp(2,2)=a33
4954         iti1=i+1
4955         iti2=i+2
4956         iti3=i+3
4957 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4958         call transpose2(EUg(1,1,i+1),e1t(1,1))
4959         call transpose2(Eug(1,1,i+2),e2t(1,1))
4960         call transpose2(Eug(1,1,i+3),e3t(1,1))
4961 !C Ematrix derivative in theta
4962         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4963         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4964         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4965
4966         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4967         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4968         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4969         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4970 !c       auxalary matrix of E i+1
4971         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4972         s1=scalar2(b1(1,iti2),auxvec(1))
4973 !c derivative of theta i+2 with constant i+3
4974         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4975 !c derivative of theta i+2 with constant i+2
4976         gs32=scalar2(b1(1,i+2),auxgvec(1))
4977 !c derivative of E matix in theta of i+1
4978         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4979
4980         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4981         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4982         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4983 !c auxilary matrix auxgvec of Ub2 with constant E matirx
4984         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4985 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4986         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4987         s2=scalar2(b1(1,i+1),auxvec(1))
4988 !c derivative of theta i+1 with constant i+3
4989         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4990 !c derivative of theta i+2 with constant i+1
4991         gs21=scalar2(b1(1,i+1),auxgvec(1))
4992 !c derivative of theta i+3 with constant i+1
4993         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4994
4995         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4996         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4997 !c ae3gte2 is derivative over i+2
4998         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4999
5000         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5001         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5002 !c i+2
5003         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5004 !c i+3
5005         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5006
5007         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5008         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5009         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5010         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5011         if (shield_mode.eq.0) then
5012         fac_shield(i)=1.0
5013         fac_shield(j)=1.0
5014         endif
5015
5016         eello_turn4=eello_turn4-(s1+s2+s3) &
5017         *fac_shield(i)*fac_shield(j)       &
5018         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5019         eello_t4=-(s1+s2+s3)  &
5020           *fac_shield(i)*fac_shield(j)
5021 !C Now derivative over shield:
5022           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5023          (shield_mode.gt.0)) then
5024 !C          print *,i,j
5025
5026           do ilist=1,ishield_list(i)
5027            iresshield=shield_list(ilist,i)
5028            do k=1,3
5029            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5030 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5031            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5032                    rlocshield &
5033             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5034             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5035            +rlocshield
5036            enddo
5037           enddo
5038           do ilist=1,ishield_list(j)
5039            iresshield=shield_list(ilist,j)
5040            do k=1,3
5041 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5042            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5043            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5044                    rlocshield  &
5045            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5046            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5047                   +rlocshield
5048 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5049
5050            enddo
5051           enddo
5052           do k=1,3
5053             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5054                    grad_shield(k,i)*eello_t4/fac_shield(i)
5055             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5056                    grad_shield(k,j)*eello_t4/fac_shield(j)
5057             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5058                    grad_shield(k,i)*eello_t4/fac_shield(i)
5059             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5060                    grad_shield(k,j)*eello_t4/fac_shield(j)
5061 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5062            enddo
5063            endif
5064 #ifdef NEWCORR
5065         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5066                        -(gs13+gsE13+gsEE1)*wturn4&
5067        *fac_shield(i)*fac_shield(j) &
5068        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5069
5070         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5071                          -(gs23+gs21+gsEE2)*wturn4&
5072        *fac_shield(i)*fac_shield(j)&
5073        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5074
5075         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5076                          -(gs32+gsE31+gsEE3)*wturn4&
5077        *fac_shield(i)*fac_shield(j)&
5078        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5079
5080
5081 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5082 !c     &   gs2
5083 #endif
5084         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5085            'eturn4',i,j,-(s1+s2+s3)
5086 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5087 !d     &    ' eello_turn4_num',8*eello_turn4_num
5088 ! Derivatives in gamma(i)
5089         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5090         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5091         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5092         s1=scalar2(b1(1,i+1),auxvec(1))
5093         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5094         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5095         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5096        *fac_shield(i)*fac_shield(j)  &
5097        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5098
5099 ! Derivatives in gamma(i+1)
5100         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5101         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5102         s2=scalar2(b1(1,iti1),auxvec(1))
5103         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5104         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5105         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5106         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5107        *fac_shield(i)*fac_shield(j)  &
5108        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5109
5110 ! Derivatives in gamma(i+2)
5111         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5112         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5113         s1=scalar2(b1(1,iti2),auxvec(1))
5114         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5115         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5116         s2=scalar2(b1(1,iti1),auxvec(1))
5117         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5118         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5119         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5120         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5121        *fac_shield(i)*fac_shield(j)  &
5122        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5123
5124 ! Cartesian derivatives
5125 ! Derivatives of this turn contributions in DC(i+2)
5126         if (j.lt.nres-1) then
5127           do l=1,3
5128             a_temp(1,1)=agg(l,1)
5129             a_temp(1,2)=agg(l,2)
5130             a_temp(2,1)=agg(l,3)
5131             a_temp(2,2)=agg(l,4)
5132             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5133             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5134             s1=scalar2(b1(1,iti2),auxvec(1))
5135             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5136             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5137             s2=scalar2(b1(1,iti1),auxvec(1))
5138             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5139             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5140             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5141             ggg(l)=-(s1+s2+s3)
5142             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5143        *fac_shield(i)*fac_shield(j)  &
5144        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5145
5146           enddo
5147         endif
5148 ! Remaining derivatives of this turn contribution
5149         do l=1,3
5150           a_temp(1,1)=aggi(l,1)
5151           a_temp(1,2)=aggi(l,2)
5152           a_temp(2,1)=aggi(l,3)
5153           a_temp(2,2)=aggi(l,4)
5154           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5155           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5156           s1=scalar2(b1(1,iti2),auxvec(1))
5157           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5158           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5159           s2=scalar2(b1(1,iti1),auxvec(1))
5160           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5161           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5162           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5163           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5164          *fac_shield(i)*fac_shield(j)  &
5165          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5166
5167
5168           a_temp(1,1)=aggi1(l,1)
5169           a_temp(1,2)=aggi1(l,2)
5170           a_temp(2,1)=aggi1(l,3)
5171           a_temp(2,2)=aggi1(l,4)
5172           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5173           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5174           s1=scalar2(b1(1,iti2),auxvec(1))
5175           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5176           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5177           s2=scalar2(b1(1,iti1),auxvec(1))
5178           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5179           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5180           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5181           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5182          *fac_shield(i)*fac_shield(j)  &
5183          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5184
5185
5186           a_temp(1,1)=aggj(l,1)
5187           a_temp(1,2)=aggj(l,2)
5188           a_temp(2,1)=aggj(l,3)
5189           a_temp(2,2)=aggj(l,4)
5190           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5191           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5192           s1=scalar2(b1(1,iti2),auxvec(1))
5193           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5194           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5195           s2=scalar2(b1(1,iti1),auxvec(1))
5196           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5197           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5198           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5199 !        if (j.lt.nres-1) then
5200           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5201          *fac_shield(i)*fac_shield(j)  &
5202          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5203 !        endif
5204
5205           a_temp(1,1)=aggj1(l,1)
5206           a_temp(1,2)=aggj1(l,2)
5207           a_temp(2,1)=aggj1(l,3)
5208           a_temp(2,2)=aggj1(l,4)
5209           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5210           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5211           s1=scalar2(b1(1,iti2),auxvec(1))
5212           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5213           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5214           s2=scalar2(b1(1,iti1),auxvec(1))
5215           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5216           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5217           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5218 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5219 !        if (j.lt.nres-1) then
5220 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5221           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5222          *fac_shield(i)*fac_shield(j)  &
5223          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5224 !            if (shield_mode.gt.0) then
5225 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5226 !            else
5227 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5228 !            endif
5229 !         endif
5230         enddo
5231          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5232           ssgradlipi*eello_t4/4.0d0*lipscale
5233          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5234           ssgradlipj*eello_t4/4.0d0*lipscale
5235          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5236           ssgradlipi*eello_t4/4.0d0*lipscale
5237          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5238           ssgradlipj*eello_t4/4.0d0*lipscale
5239
5240       return
5241       end subroutine eturn4
5242 !-----------------------------------------------------------------------------
5243       subroutine unormderiv(u,ugrad,unorm,ungrad)
5244 ! This subroutine computes the derivatives of a normalized vector u, given
5245 ! the derivatives computed without normalization conditions, ugrad. Returns
5246 ! ungrad.
5247 !      implicit none
5248       real(kind=8),dimension(3) :: u,vec
5249       real(kind=8),dimension(3,3) ::ugrad,ungrad
5250       real(kind=8) :: unorm      !,scalar
5251       integer :: i,j
5252 !      write (2,*) 'ugrad',ugrad
5253 !      write (2,*) 'u',u
5254       do i=1,3
5255         vec(i)=scalar(ugrad(1,i),u(1))
5256       enddo
5257 !      write (2,*) 'vec',vec
5258       do i=1,3
5259         do j=1,3
5260           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5261         enddo
5262       enddo
5263 !      write (2,*) 'ungrad',ungrad
5264       return
5265       end subroutine unormderiv
5266 !-----------------------------------------------------------------------------
5267       subroutine escp_soft_sphere(evdw2,evdw2_14)
5268 !
5269 ! This subroutine calculates the excluded-volume interaction energy between
5270 ! peptide-group centers and side chains and its gradient in virtual-bond and
5271 ! side-chain vectors.
5272 !
5273 !      implicit real*8 (a-h,o-z)
5274 !      include 'DIMENSIONS'
5275 !      include 'COMMON.GEO'
5276 !      include 'COMMON.VAR'
5277 !      include 'COMMON.LOCAL'
5278 !      include 'COMMON.CHAIN'
5279 !      include 'COMMON.DERIV'
5280 !      include 'COMMON.INTERACT'
5281 !      include 'COMMON.FFIELD'
5282 !      include 'COMMON.IOUNITS'
5283 !      include 'COMMON.CONTROL'
5284       real(kind=8),dimension(3) :: ggg
5285 !el local variables
5286       integer :: i,iint,j,k,iteli,itypj
5287       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5288                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5289
5290       evdw2=0.0D0
5291       evdw2_14=0.0d0
5292       r0_scp=4.5d0
5293 !d    print '(a)','Enter ESCP'
5294 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5295       do i=iatscp_s,iatscp_e
5296         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5297         iteli=itel(i)
5298         xi=0.5D0*(c(1,i)+c(1,i+1))
5299         yi=0.5D0*(c(2,i)+c(2,i+1))
5300         zi=0.5D0*(c(3,i)+c(3,i+1))
5301           call to_box(xi,yi,zi)
5302
5303         do iint=1,nscp_gr(i)
5304
5305         do j=iscpstart(i,iint),iscpend(i,iint)
5306           if (itype(j,1).eq.ntyp1) cycle
5307           itypj=iabs(itype(j,1))
5308 ! Uncomment following three lines for SC-p interactions
5309 !         xj=c(1,nres+j)-xi
5310 !         yj=c(2,nres+j)-yi
5311 !         zj=c(3,nres+j)-zi
5312 ! Uncomment following three lines for Ca-p interactions
5313           xj=c(1,j)-xi
5314           yj=c(2,j)-yi
5315           zj=c(3,j)-zi
5316           call to_box(xj,yj,zj)
5317           xj=boxshift(xj-xi,boxxsize)
5318           yj=boxshift(yj-yi,boxysize)
5319           zj=boxshift(zj-zi,boxzsize)
5320           rij=xj*xj+yj*yj+zj*zj
5321           r0ij=r0_scp
5322           r0ijsq=r0ij*r0ij
5323           if (rij.lt.r0ijsq) then
5324             evdwij=0.25d0*(rij-r0ijsq)**2
5325             fac=rij-r0ijsq
5326           else
5327             evdwij=0.0d0
5328             fac=0.0d0
5329           endif
5330           evdw2=evdw2+evdwij
5331 !
5332 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5333 !
5334           ggg(1)=xj*fac
5335           ggg(2)=yj*fac
5336           ggg(3)=zj*fac
5337 !grad          if (j.lt.i) then
5338 !d          write (iout,*) 'j<i'
5339 ! Uncomment following three lines for SC-p interactions
5340 !           do k=1,3
5341 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5342 !           enddo
5343 !grad          else
5344 !d          write (iout,*) 'j>i'
5345 !grad            do k=1,3
5346 !grad              ggg(k)=-ggg(k)
5347 ! Uncomment following line for SC-p interactions
5348 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5349 !grad            enddo
5350 !grad          endif
5351 !grad          do k=1,3
5352 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5353 !grad          enddo
5354 !grad          kstart=min0(i+1,j)
5355 !grad          kend=max0(i-1,j-1)
5356 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5357 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5358 !grad          do k=kstart,kend
5359 !grad            do l=1,3
5360 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5361 !grad            enddo
5362 !grad          enddo
5363           do k=1,3
5364             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5365             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5366           enddo
5367         enddo
5368
5369         enddo ! iint
5370       enddo ! i
5371       return
5372       end subroutine escp_soft_sphere
5373 !-----------------------------------------------------------------------------
5374       subroutine escp(evdw2,evdw2_14)
5375 !
5376 ! This subroutine calculates the excluded-volume interaction energy between
5377 ! peptide-group centers and side chains and its gradient in virtual-bond and
5378 ! side-chain vectors.
5379 !
5380 !      implicit real*8 (a-h,o-z)
5381 !      include 'DIMENSIONS'
5382 !      include 'COMMON.GEO'
5383 !      include 'COMMON.VAR'
5384 !      include 'COMMON.LOCAL'
5385 !      include 'COMMON.CHAIN'
5386 !      include 'COMMON.DERIV'
5387 !      include 'COMMON.INTERACT'
5388 !      include 'COMMON.FFIELD'
5389 !      include 'COMMON.IOUNITS'
5390 !      include 'COMMON.CONTROL'
5391       real(kind=8),dimension(3) :: ggg
5392 !el local variables
5393       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5394       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5395                    e1,e2,evdwij,rij
5396       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5397                     dist_temp, dist_init
5398       integer xshift,yshift,zshift
5399
5400       evdw2=0.0D0
5401       evdw2_14=0.0d0
5402 !d    print '(a)','Enter ESCP'
5403 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5404 !      do i=iatscp_s,iatscp_e
5405       if (nres_molec(1).eq.0) return
5406        do icont=g_listscp_start,g_listscp_end
5407         i=newcontlistscpi(icont)
5408         j=newcontlistscpj(icont)
5409         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5410         iteli=itel(i)
5411         xi=0.5D0*(c(1,i)+c(1,i+1))
5412         yi=0.5D0*(c(2,i)+c(2,i+1))
5413         zi=0.5D0*(c(3,i)+c(3,i+1))
5414         call to_box(xi,yi,zi)
5415
5416 !        do iint=1,nscp_gr(i)
5417
5418 !        do j=iscpstart(i,iint),iscpend(i,iint)
5419           itypj=iabs(itype(j,1))
5420           if (itypj.eq.ntyp1) cycle
5421 ! Uncomment following three lines for SC-p interactions
5422 !         xj=c(1,nres+j)-xi
5423 !         yj=c(2,nres+j)-yi
5424 !         zj=c(3,nres+j)-zi
5425 ! Uncomment following three lines for Ca-p interactions
5426 !          xj=c(1,j)-xi
5427 !          yj=c(2,j)-yi
5428 !          zj=c(3,j)-zi
5429           xj=c(1,j)
5430           yj=c(2,j)
5431           zj=c(3,j)
5432
5433           call to_box(xj,yj,zj)
5434           xj=boxshift(xj-xi,boxxsize)
5435           yj=boxshift(yj-yi,boxysize)
5436           zj=boxshift(zj-zi,boxzsize)
5437
5438           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5439           rij=dsqrt(1.0d0/rrij)
5440             sss_ele_cut=sscale_ele(rij)
5441             sss_ele_grad=sscagrad_ele(rij)
5442 !            print *,sss_ele_cut,sss_ele_grad,&
5443 !            (rij),r_cut_ele,rlamb_ele
5444             if (sss_ele_cut.le.0.0) cycle
5445           fac=rrij**expon2
5446           e1=fac*fac*aad(itypj,iteli)
5447           e2=fac*bad(itypj,iteli)
5448           if (iabs(j-i) .le. 2) then
5449             e1=scal14*e1
5450             e2=scal14*e2
5451             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5452           endif
5453           evdwij=e1+e2
5454           evdw2=evdw2+evdwij*sss_ele_cut
5455 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5456 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5457           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5458              'evdw2',i,j,evdwij
5459 !
5460 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5461 !
5462           fac=-(evdwij+e1)*rrij*sss_ele_cut
5463           fac=fac+evdwij*sss_ele_grad/rij/expon
5464           ggg(1)=xj*fac
5465           ggg(2)=yj*fac
5466           ggg(3)=zj*fac
5467 !grad          if (j.lt.i) then
5468 !d          write (iout,*) 'j<i'
5469 ! Uncomment following three lines for SC-p interactions
5470 !           do k=1,3
5471 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5472 !           enddo
5473 !grad          else
5474 !d          write (iout,*) 'j>i'
5475 !grad            do k=1,3
5476 !grad              ggg(k)=-ggg(k)
5477 ! Uncomment following line for SC-p interactions
5478 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5479 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5480 !grad            enddo
5481 !grad          endif
5482 !grad          do k=1,3
5483 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5484 !grad          enddo
5485 !grad          kstart=min0(i+1,j)
5486 !grad          kend=max0(i-1,j-1)
5487 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5488 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5489 !grad          do k=kstart,kend
5490 !grad            do l=1,3
5491 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5492 !grad            enddo
5493 !grad          enddo
5494           do k=1,3
5495             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5496             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5497           enddo
5498 !        enddo
5499
5500 !        enddo ! iint
5501       enddo ! i
5502       do i=1,nct
5503         do j=1,3
5504           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5505           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5506           gradx_scp(j,i)=expon*gradx_scp(j,i)
5507         enddo
5508       enddo
5509 !******************************************************************************
5510 !
5511 !                              N O T E !!!
5512 !
5513 ! To save time the factor EXPON has been extracted from ALL components
5514 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5515 ! use!
5516 !
5517 !******************************************************************************
5518       return
5519       end subroutine escp
5520 !-----------------------------------------------------------------------------
5521       subroutine edis(ehpb)
5522 !
5523 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5524 !
5525 !      implicit real*8 (a-h,o-z)
5526 !      include 'DIMENSIONS'
5527 !      include 'COMMON.SBRIDGE'
5528 !      include 'COMMON.CHAIN'
5529 !      include 'COMMON.DERIV'
5530 !      include 'COMMON.VAR'
5531 !      include 'COMMON.INTERACT'
5532 !      include 'COMMON.IOUNITS'
5533       real(kind=8),dimension(3) :: ggg
5534 !el local variables
5535       integer :: i,j,ii,jj,iii,jjj,k
5536       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5537
5538       ehpb=0.0D0
5539 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5540 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5541       if (link_end.eq.0) return
5542       do i=link_start,link_end
5543 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5544 ! CA-CA distance used in regularization of structure.
5545         ii=ihpb(i)
5546         jj=jhpb(i)
5547 ! iii and jjj point to the residues for which the distance is assigned.
5548         if (ii.gt.nres) then
5549           iii=ii-nres
5550           jjj=jj-nres
5551         else
5552           iii=ii
5553           jjj=jj
5554         endif
5555 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5556 !     &    dhpb(i),dhpb1(i),forcon(i)
5557 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5558 !    distance and angle dependent SS bond potential.
5559 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5560 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5561         if (.not.dyn_ss .and. i.le.nss) then
5562 ! 15/02/13 CC dynamic SSbond - additional check
5563          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5564         iabs(itype(jjj,1)).eq.1) then
5565           call ssbond_ene(iii,jjj,eij)
5566           ehpb=ehpb+2*eij
5567 !          write (iout,*) "eij",eij,iii,jjj
5568          endif
5569         else if (ii.gt.nres .and. jj.gt.nres) then
5570 !c Restraints from contact prediction
5571           dd=dist(ii,jj)
5572           if (constr_dist.eq.11) then
5573             ehpb=ehpb+fordepth(i)**4.0d0 &
5574                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5575             fac=fordepth(i)**4.0d0 &
5576                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5577           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5578             ehpb,fordepth(i),dd
5579            else
5580           if (dhpb1(i).gt.0.0d0) then
5581             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5582             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5583 !c            write (iout,*) "beta nmr",
5584 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5585           else
5586             dd=dist(ii,jj)
5587             rdis=dd-dhpb(i)
5588 !C Get the force constant corresponding to this distance.
5589             waga=forcon(i)
5590 !C Calculate the contribution to energy.
5591             ehpb=ehpb+waga*rdis*rdis
5592 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5593 !C
5594 !C Evaluate gradient.
5595 !C
5596             fac=waga*rdis/dd
5597           endif
5598           endif
5599           do j=1,3
5600             ggg(j)=fac*(c(j,jj)-c(j,ii))
5601           enddo
5602           do j=1,3
5603             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5604             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5605           enddo
5606           do k=1,3
5607             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5608             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5609           enddo
5610         else
5611           dd=dist(ii,jj)
5612           if (constr_dist.eq.11) then
5613             ehpb=ehpb+fordepth(i)**4.0d0 &
5614                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5615             fac=fordepth(i)**4.0d0 &
5616                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5617           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5618          ehpb,fordepth(i),dd
5619            else
5620           if (dhpb1(i).gt.0.0d0) then
5621             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5622             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5623 !c            write (iout,*) "alph nmr",
5624 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5625           else
5626             rdis=dd-dhpb(i)
5627 !C Get the force constant corresponding to this distance.
5628             waga=forcon(i)
5629 !C Calculate the contribution to energy.
5630             ehpb=ehpb+waga*rdis*rdis
5631 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5632 !C
5633 !C Evaluate gradient.
5634 !C
5635             fac=waga*rdis/dd
5636           endif
5637           endif
5638
5639             do j=1,3
5640               ggg(j)=fac*(c(j,jj)-c(j,ii))
5641             enddo
5642 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5643 !C If this is a SC-SC distance, we need to calculate the contributions to the
5644 !C Cartesian gradient in the SC vectors (ghpbx).
5645           if (iii.lt.ii) then
5646           do j=1,3
5647             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5648             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5649           enddo
5650           endif
5651 !cgrad        do j=iii,jjj-1
5652 !cgrad          do k=1,3
5653 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5654 !cgrad          enddo
5655 !cgrad        enddo
5656           do k=1,3
5657             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5658             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5659           enddo
5660         endif
5661       enddo
5662       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5663
5664       return
5665       end subroutine edis
5666 !-----------------------------------------------------------------------------
5667       subroutine ssbond_ene(i,j,eij)
5668 !
5669 ! Calculate the distance and angle dependent SS-bond potential energy
5670 ! using a free-energy function derived based on RHF/6-31G** ab initio
5671 ! calculations of diethyl disulfide.
5672 !
5673 ! A. Liwo and U. Kozlowska, 11/24/03
5674 !
5675 !      implicit real*8 (a-h,o-z)
5676 !      include 'DIMENSIONS'
5677 !      include 'COMMON.SBRIDGE'
5678 !      include 'COMMON.CHAIN'
5679 !      include 'COMMON.DERIV'
5680 !      include 'COMMON.LOCAL'
5681 !      include 'COMMON.INTERACT'
5682 !      include 'COMMON.VAR'
5683 !      include 'COMMON.IOUNITS'
5684       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5685 !el local variables
5686       integer :: i,j,itypi,itypj,k
5687       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5688                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5689                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5690                    cosphi,ggk
5691
5692       itypi=iabs(itype(i,1))
5693       xi=c(1,nres+i)
5694       yi=c(2,nres+i)
5695       zi=c(3,nres+i)
5696           call to_box(xi,yi,zi)
5697
5698       dxi=dc_norm(1,nres+i)
5699       dyi=dc_norm(2,nres+i)
5700       dzi=dc_norm(3,nres+i)
5701 !      dsci_inv=dsc_inv(itypi)
5702       dsci_inv=vbld_inv(nres+i)
5703       itypj=iabs(itype(j,1))
5704 !      dscj_inv=dsc_inv(itypj)
5705       dscj_inv=vbld_inv(nres+j)
5706       xj=c(1,nres+j)
5707       yj=c(2,nres+j)
5708       zj=c(3,nres+j)
5709           call to_box(xj,yj,zj)
5710       xj=boxshift(xj-xi,boxxsize)
5711       yj=boxshift(yj-yi,boxysize)
5712       zj=boxshift(zj-zi,boxzsize)
5713       dxj=dc_norm(1,nres+j)
5714       dyj=dc_norm(2,nres+j)
5715       dzj=dc_norm(3,nres+j)
5716       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5717       rij=dsqrt(rrij)
5718       erij(1)=xj*rij
5719       erij(2)=yj*rij
5720       erij(3)=zj*rij
5721       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5722       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5723       om12=dxi*dxj+dyi*dyj+dzi*dzj
5724       do k=1,3
5725         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5726         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5727       enddo
5728       rij=1.0d0/rij
5729       deltad=rij-d0cm
5730       deltat1=1.0d0-om1
5731       deltat2=1.0d0+om2
5732       deltat12=om2-om1+2.0d0
5733       cosphi=om12-om1*om2
5734       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5735         +akct*deltad*deltat12 &
5736         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5737 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5738 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5739 !       " deltat12",deltat12," eij",eij
5740       ed=2*akcm*deltad+akct*deltat12
5741       pom1=akct*deltad
5742       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5743       eom1=-2*akth*deltat1-pom1-om2*pom2
5744       eom2= 2*akth*deltat2+pom1-om1*pom2
5745       eom12=pom2
5746       do k=1,3
5747         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5748         ghpbx(k,i)=ghpbx(k,i)-ggk &
5749                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5750                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5751         ghpbx(k,j)=ghpbx(k,j)+ggk &
5752                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5753                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5754         ghpbc(k,i)=ghpbc(k,i)-ggk
5755         ghpbc(k,j)=ghpbc(k,j)+ggk
5756       enddo
5757 !
5758 ! Calculate the components of the gradient in DC and X
5759 !
5760 !grad      do k=i,j-1
5761 !grad        do l=1,3
5762 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5763 !grad        enddo
5764 !grad      enddo
5765       return
5766       end subroutine ssbond_ene
5767 !-----------------------------------------------------------------------------
5768       subroutine ebond(estr)
5769 !
5770 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5771 !
5772 !      implicit real*8 (a-h,o-z)
5773 !      include 'DIMENSIONS'
5774 !      include 'COMMON.LOCAL'
5775 !      include 'COMMON.GEO'
5776 !      include 'COMMON.INTERACT'
5777 !      include 'COMMON.DERIV'
5778 !      include 'COMMON.VAR'
5779 !      include 'COMMON.CHAIN'
5780 !      include 'COMMON.IOUNITS'
5781 !      include 'COMMON.NAMES'
5782 !      include 'COMMON.FFIELD'
5783 !      include 'COMMON.CONTROL'
5784 !      include 'COMMON.SETUP'
5785       real(kind=8),dimension(3) :: u,ud
5786 !el local variables
5787       integer :: i,j,iti,nbi,k
5788       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5789                    uprod1,uprod2
5790
5791       estr=0.0d0
5792       estr1=0.0d0
5793 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5794 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5795
5796       do i=ibondp_start,ibondp_end
5797         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5798         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5799 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5800 !C          do j=1,3
5801 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5802 !C            *dc(j,i-1)/vbld(i)
5803 !C          enddo
5804 !C          if (energy_dec) write(iout,*) &
5805 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5806         diff = vbld(i)-vbldpDUM
5807         else
5808         diff = vbld(i)-vbldp0
5809         endif
5810         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5811            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5812         estr=estr+diff*diff
5813         do j=1,3
5814           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5815         enddo
5816 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5817 !        endif
5818       enddo
5819       estr=0.5d0*AKP*estr+estr1
5820 !      print *,"estr_bb",estr,AKP
5821 !
5822 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5823 !
5824       do i=ibond_start,ibond_end
5825         iti=iabs(itype(i,1))
5826         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5827         if (iti.ne.10 .and. iti.ne.ntyp1) then
5828           nbi=nbondterm(iti)
5829           if (nbi.eq.1) then
5830             diff=vbld(i+nres)-vbldsc0(1,iti)
5831             if (energy_dec) write (iout,*) &
5832             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5833             AKSC(1,iti),AKSC(1,iti)*diff*diff
5834             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5835 !            print *,"estr_sc",estr
5836             do j=1,3
5837               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5838             enddo
5839           else
5840             do j=1,nbi
5841               diff=vbld(i+nres)-vbldsc0(j,iti)
5842               ud(j)=aksc(j,iti)*diff
5843               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5844             enddo
5845             uprod=u(1)
5846             do j=2,nbi
5847               uprod=uprod*u(j)
5848             enddo
5849             usum=0.0d0
5850             usumsqder=0.0d0
5851             do j=1,nbi
5852               uprod1=1.0d0
5853               uprod2=1.0d0
5854               do k=1,nbi
5855                 if (k.ne.j) then
5856                   uprod1=uprod1*u(k)
5857                   uprod2=uprod2*u(k)*u(k)
5858                 endif
5859               enddo
5860               usum=usum+uprod1
5861               usumsqder=usumsqder+ud(j)*uprod2
5862             enddo
5863             estr=estr+uprod/usum
5864 !            print *,"estr_sc",estr,i
5865
5866              if (energy_dec) write (iout,*) &
5867             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5868             AKSC(1,iti),uprod/usum
5869             do j=1,3
5870              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5871             enddo
5872           endif
5873         endif
5874       enddo
5875       return
5876       end subroutine ebond
5877 #ifdef CRYST_THETA
5878 !-----------------------------------------------------------------------------
5879       subroutine ebend(etheta)
5880 !
5881 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5882 ! angles gamma and its derivatives in consecutive thetas and gammas.
5883 !
5884       use comm_calcthet
5885 !      implicit real*8 (a-h,o-z)
5886 !      include 'DIMENSIONS'
5887 !      include 'COMMON.LOCAL'
5888 !      include 'COMMON.GEO'
5889 !      include 'COMMON.INTERACT'
5890 !      include 'COMMON.DERIV'
5891 !      include 'COMMON.VAR'
5892 !      include 'COMMON.CHAIN'
5893 !      include 'COMMON.IOUNITS'
5894 !      include 'COMMON.NAMES'
5895 !      include 'COMMON.FFIELD'
5896 !      include 'COMMON.CONTROL'
5897 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5898 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5899 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5900 !el      integer :: it
5901 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5902 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5903 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5904 !el local variables
5905       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5906        ichir21,ichir22
5907       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5908        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5909        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5910       real(kind=8),dimension(2) :: y,z
5911
5912       delta=0.02d0*pi
5913 !      time11=dexp(-2*time)
5914 !      time12=1.0d0
5915       etheta=0.0D0
5916 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5917       do i=ithet_start,ithet_end
5918         if (itype(i-1,1).eq.ntyp1) cycle
5919 ! Zero the energy function and its derivative at 0 or pi.
5920         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5921         it=itype(i-1,1)
5922         ichir1=isign(1,itype(i-2,1))
5923         ichir2=isign(1,itype(i,1))
5924          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5925          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5926          if (itype(i-1,1).eq.10) then
5927           itype1=isign(10,itype(i-2,1))
5928           ichir11=isign(1,itype(i-2,1))
5929           ichir12=isign(1,itype(i-2,1))
5930           itype2=isign(10,itype(i,1))
5931           ichir21=isign(1,itype(i,1))
5932           ichir22=isign(1,itype(i,1))
5933          endif
5934
5935         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5936 #ifdef OSF
5937           phii=phi(i)
5938           if (phii.ne.phii) phii=150.0
5939 #else
5940           phii=phi(i)
5941 #endif
5942           y(1)=dcos(phii)
5943           y(2)=dsin(phii)
5944         else
5945           y(1)=0.0D0
5946           y(2)=0.0D0
5947         endif
5948         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5949 #ifdef OSF
5950           phii1=phi(i+1)
5951           if (phii1.ne.phii1) phii1=150.0
5952           phii1=pinorm(phii1)
5953           z(1)=cos(phii1)
5954 #else
5955           phii1=phi(i+1)
5956           z(1)=dcos(phii1)
5957 #endif
5958           z(2)=dsin(phii1)
5959         else
5960           z(1)=0.0D0
5961           z(2)=0.0D0
5962         endif
5963 ! Calculate the "mean" value of theta from the part of the distribution
5964 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5965 ! In following comments this theta will be referred to as t_c.
5966         thet_pred_mean=0.0d0
5967         do k=1,2
5968             athetk=athet(k,it,ichir1,ichir2)
5969             bthetk=bthet(k,it,ichir1,ichir2)
5970           if (it.eq.10) then
5971              athetk=athet(k,itype1,ichir11,ichir12)
5972              bthetk=bthet(k,itype2,ichir21,ichir22)
5973           endif
5974          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5975         enddo
5976         dthett=thet_pred_mean*ssd
5977         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5978 ! Derivatives of the "mean" values in gamma1 and gamma2.
5979         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5980                +athet(2,it,ichir1,ichir2)*y(1))*ss
5981         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5982                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5983          if (it.eq.10) then
5984         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5985              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5986         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5987                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5988          endif
5989         if (theta(i).gt.pi-delta) then
5990           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5991                E_tc0)
5992           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5993           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5994           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5995               E_theta)
5996           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5997               E_tc)
5998         else if (theta(i).lt.delta) then
5999           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6000           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6001           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6002               E_theta)
6003           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6004           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6005               E_tc)
6006         else
6007           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6008               E_theta,E_tc)
6009         endif
6010         etheta=etheta+ethetai
6011         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6012             'ebend',i,ethetai
6013         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6014         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6015         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6016       enddo
6017 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6018
6019 ! Ufff.... We've done all this!!!
6020       return
6021       end subroutine ebend
6022 !-----------------------------------------------------------------------------
6023       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6024
6025       use comm_calcthet
6026 !      implicit real*8 (a-h,o-z)
6027 !      include 'DIMENSIONS'
6028 !      include 'COMMON.LOCAL'
6029 !      include 'COMMON.IOUNITS'
6030 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6031 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6032 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6033       integer :: i,j,k
6034       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6035 !el      integer :: it
6036 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6037 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6038 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6039 !el local variables
6040       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6041        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6042
6043 ! Calculate the contributions to both Gaussian lobes.
6044 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6045 ! The "polynomial part" of the "standard deviation" of this part of
6046 ! the distribution.
6047         sig=polthet(3,it)
6048         do j=2,0,-1
6049           sig=sig*thet_pred_mean+polthet(j,it)
6050         enddo
6051 ! Derivative of the "interior part" of the "standard deviation of the"
6052 ! gamma-dependent Gaussian lobe in t_c.
6053         sigtc=3*polthet(3,it)
6054         do j=2,1,-1
6055           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6056         enddo
6057         sigtc=sig*sigtc
6058 ! Set the parameters of both Gaussian lobes of the distribution.
6059 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6060         fac=sig*sig+sigc0(it)
6061         sigcsq=fac+fac
6062         sigc=1.0D0/sigcsq
6063 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6064         sigsqtc=-4.0D0*sigcsq*sigtc
6065 !       print *,i,sig,sigtc,sigsqtc
6066 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6067         sigtc=-sigtc/(fac*fac)
6068 ! Following variable is sigma(t_c)**(-2)
6069         sigcsq=sigcsq*sigcsq
6070         sig0i=sig0(it)
6071         sig0inv=1.0D0/sig0i**2
6072         delthec=thetai-thet_pred_mean
6073         delthe0=thetai-theta0i
6074         term1=-0.5D0*sigcsq*delthec*delthec
6075         term2=-0.5D0*sig0inv*delthe0*delthe0
6076 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6077 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6078 ! to the energy (this being the log of the distribution) at the end of energy
6079 ! term evaluation for this virtual-bond angle.
6080         if (term1.gt.term2) then
6081           termm=term1
6082           term2=dexp(term2-termm)
6083           term1=1.0d0
6084         else
6085           termm=term2
6086           term1=dexp(term1-termm)
6087           term2=1.0d0
6088         endif
6089 ! The ratio between the gamma-independent and gamma-dependent lobes of
6090 ! the distribution is a Gaussian function of thet_pred_mean too.
6091         diffak=gthet(2,it)-thet_pred_mean
6092         ratak=diffak/gthet(3,it)**2
6093         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6094 ! Let's differentiate it in thet_pred_mean NOW.
6095         aktc=ak*ratak
6096 ! Now put together the distribution terms to make complete distribution.
6097         termexp=term1+ak*term2
6098         termpre=sigc+ak*sig0i
6099 ! Contribution of the bending energy from this theta is just the -log of
6100 ! the sum of the contributions from the two lobes and the pre-exponential
6101 ! factor. Simple enough, isn't it?
6102         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6103 ! NOW the derivatives!!!
6104 ! 6/6/97 Take into account the deformation.
6105         E_theta=(delthec*sigcsq*term1 &
6106              +ak*delthe0*sig0inv*term2)/termexp
6107         E_tc=((sigtc+aktc*sig0i)/termpre &
6108             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6109              aktc*term2)/termexp)
6110       return
6111       end subroutine theteng
6112 #else
6113 !-----------------------------------------------------------------------------
6114       subroutine ebend(etheta)
6115 !
6116 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6117 ! angles gamma and its derivatives in consecutive thetas and gammas.
6118 ! ab initio-derived potentials from
6119 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6120 !
6121 !      implicit real*8 (a-h,o-z)
6122 !      include 'DIMENSIONS'
6123 !      include 'COMMON.LOCAL'
6124 !      include 'COMMON.GEO'
6125 !      include 'COMMON.INTERACT'
6126 !      include 'COMMON.DERIV'
6127 !      include 'COMMON.VAR'
6128 !      include 'COMMON.CHAIN'
6129 !      include 'COMMON.IOUNITS'
6130 !      include 'COMMON.NAMES'
6131 !      include 'COMMON.FFIELD'
6132 !      include 'COMMON.CONTROL'
6133       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6134       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6135       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6136       logical :: lprn=.false., lprn1=.false.
6137 !el local variables
6138       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6139       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6140       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6141 ! local variables for constrains
6142       real(kind=8) :: difi,thetiii
6143        integer itheta
6144 !      write(iout,*) "in ebend",ithet_start,ithet_end
6145       call flush(iout)
6146       etheta=0.0D0
6147       do i=ithet_start,ithet_end
6148         if (itype(i-1,1).eq.ntyp1) cycle
6149         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6150         if (iabs(itype(i+1,1)).eq.20) iblock=2
6151         if (iabs(itype(i+1,1)).ne.20) iblock=1
6152         dethetai=0.0d0
6153         dephii=0.0d0
6154         dephii1=0.0d0
6155         theti2=0.5d0*theta(i)
6156         ityp2=ithetyp((itype(i-1,1)))
6157         do k=1,nntheterm
6158           coskt(k)=dcos(k*theti2)
6159           sinkt(k)=dsin(k*theti2)
6160         enddo
6161         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6162 #ifdef OSF
6163           phii=phi(i)
6164           if (phii.ne.phii) phii=150.0
6165 #else
6166           phii=phi(i)
6167 #endif
6168           ityp1=ithetyp((itype(i-2,1)))
6169 ! propagation of chirality for glycine type
6170           do k=1,nsingle
6171             cosph1(k)=dcos(k*phii)
6172             sinph1(k)=dsin(k*phii)
6173           enddo
6174         else
6175           phii=0.0d0
6176           ityp1=ithetyp(itype(i-2,1))
6177           do k=1,nsingle
6178             cosph1(k)=0.0d0
6179             sinph1(k)=0.0d0
6180           enddo
6181         endif
6182         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6183 #ifdef OSF
6184           phii1=phi(i+1)
6185           if (phii1.ne.phii1) phii1=150.0
6186           phii1=pinorm(phii1)
6187 #else
6188           phii1=phi(i+1)
6189 #endif
6190           ityp3=ithetyp((itype(i,1)))
6191           do k=1,nsingle
6192             cosph2(k)=dcos(k*phii1)
6193             sinph2(k)=dsin(k*phii1)
6194           enddo
6195         else
6196           phii1=0.0d0
6197           ityp3=ithetyp(itype(i,1))
6198           do k=1,nsingle
6199             cosph2(k)=0.0d0
6200             sinph2(k)=0.0d0
6201           enddo
6202         endif
6203         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6204         do k=1,ndouble
6205           do l=1,k-1
6206             ccl=cosph1(l)*cosph2(k-l)
6207             ssl=sinph1(l)*sinph2(k-l)
6208             scl=sinph1(l)*cosph2(k-l)
6209             csl=cosph1(l)*sinph2(k-l)
6210             cosph1ph2(l,k)=ccl-ssl
6211             cosph1ph2(k,l)=ccl+ssl
6212             sinph1ph2(l,k)=scl+csl
6213             sinph1ph2(k,l)=scl-csl
6214           enddo
6215         enddo
6216         if (lprn) then
6217         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6218           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6219         write (iout,*) "coskt and sinkt"
6220         do k=1,nntheterm
6221           write (iout,*) k,coskt(k),sinkt(k)
6222         enddo
6223         endif
6224         do k=1,ntheterm
6225           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6226           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6227             *coskt(k)
6228           if (lprn) &
6229           write (iout,*) "k",k,&
6230            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6231            " ethetai",ethetai
6232         enddo
6233         if (lprn) then
6234         write (iout,*) "cosph and sinph"
6235         do k=1,nsingle
6236           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6237         enddo
6238         write (iout,*) "cosph1ph2 and sinph2ph2"
6239         do k=2,ndouble
6240           do l=1,k-1
6241             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6242                sinph1ph2(l,k),sinph1ph2(k,l)
6243           enddo
6244         enddo
6245         write(iout,*) "ethetai",ethetai
6246         endif
6247         do m=1,ntheterm2
6248           do k=1,nsingle
6249             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6250                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6251                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6252                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6253             ethetai=ethetai+sinkt(m)*aux
6254             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6255             dephii=dephii+k*sinkt(m)* &
6256                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6257                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6258             dephii1=dephii1+k*sinkt(m)* &
6259                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6260                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6261             if (lprn) &
6262             write (iout,*) "m",m," k",k," bbthet", &
6263                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6264                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6265                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6266                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6267           enddo
6268         enddo
6269         if (lprn) &
6270         write(iout,*) "ethetai",ethetai
6271         do m=1,ntheterm3
6272           do k=2,ndouble
6273             do l=1,k-1
6274               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6275                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6276                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6277                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6278               ethetai=ethetai+sinkt(m)*aux
6279               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6280               dephii=dephii+l*sinkt(m)* &
6281                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6282                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6283                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6284                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6285               dephii1=dephii1+(k-l)*sinkt(m)* &
6286                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6287                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6288                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6289                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6290               if (lprn) then
6291               write (iout,*) "m",m," k",k," l",l," ffthet",&
6292                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6293                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6294                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6295                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6296                   " ethetai",ethetai
6297               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6298                   cosph1ph2(k,l)*sinkt(m),&
6299                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6300               endif
6301             enddo
6302           enddo
6303         enddo
6304 10      continue
6305 !        lprn1=.true.
6306         if (lprn1) &
6307           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6308          i,theta(i)*rad2deg,phii*rad2deg,&
6309          phii1*rad2deg,ethetai
6310 !        lprn1=.false.
6311         etheta=etheta+ethetai
6312         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6313                                     'ebend',i,ethetai
6314         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6315         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6316         gloc(nphi+i-2,icg)=wang*dethetai
6317       enddo
6318 !-----------thete constrains
6319 !      if (tor_mode.ne.2) then
6320
6321       return
6322       end subroutine ebend
6323 #endif
6324 #ifdef CRYST_SC
6325 !-----------------------------------------------------------------------------
6326       subroutine esc(escloc)
6327 ! Calculate the local energy of a side chain and its derivatives in the
6328 ! corresponding virtual-bond valence angles THETA and the spherical angles
6329 ! ALPHA and OMEGA.
6330 !
6331       use comm_sccalc
6332 !      implicit real*8 (a-h,o-z)
6333 !      include 'DIMENSIONS'
6334 !      include 'COMMON.GEO'
6335 !      include 'COMMON.LOCAL'
6336 !      include 'COMMON.VAR'
6337 !      include 'COMMON.INTERACT'
6338 !      include 'COMMON.DERIV'
6339 !      include 'COMMON.CHAIN'
6340 !      include 'COMMON.IOUNITS'
6341 !      include 'COMMON.NAMES'
6342 !      include 'COMMON.FFIELD'
6343 !      include 'COMMON.CONTROL'
6344       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6345          ddersc0,ddummy,xtemp,temp
6346 !el      real(kind=8) :: time11,time12,time112,theti
6347       real(kind=8) :: escloc,delta
6348 !el      integer :: it,nlobit
6349 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6350 !el local variables
6351       integer :: i,k
6352       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6353        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6354       delta=0.02d0*pi
6355       escloc=0.0D0
6356 !     write (iout,'(a)') 'ESC'
6357       do i=loc_start,loc_end
6358         it=itype(i,1)
6359         if (it.eq.ntyp1) cycle
6360         if (it.eq.10) goto 1
6361         nlobit=nlob(iabs(it))
6362 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6363 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6364         theti=theta(i+1)-pipol
6365         x(1)=dtan(theti)
6366         x(2)=alph(i)
6367         x(3)=omeg(i)
6368
6369         if (x(2).gt.pi-delta) then
6370           xtemp(1)=x(1)
6371           xtemp(2)=pi-delta
6372           xtemp(3)=x(3)
6373           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6374           xtemp(2)=pi
6375           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6376           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6377               escloci,dersc(2))
6378           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6379               ddersc0(1),dersc(1))
6380           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6381               ddersc0(3),dersc(3))
6382           xtemp(2)=pi-delta
6383           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6384           xtemp(2)=pi
6385           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6386           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6387                   dersc0(2),esclocbi,dersc02)
6388           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6389                   dersc12,dersc01)
6390           call splinthet(x(2),0.5d0*delta,ss,ssd)
6391           dersc0(1)=dersc01
6392           dersc0(2)=dersc02
6393           dersc0(3)=0.0d0
6394           do k=1,3
6395             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6396           enddo
6397           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6398 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6399 !    &             esclocbi,ss,ssd
6400           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6401 !         escloci=esclocbi
6402 !         write (iout,*) escloci
6403         else if (x(2).lt.delta) then
6404           xtemp(1)=x(1)
6405           xtemp(2)=delta
6406           xtemp(3)=x(3)
6407           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6408           xtemp(2)=0.0d0
6409           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6410           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6411               escloci,dersc(2))
6412           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6413               ddersc0(1),dersc(1))
6414           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6415               ddersc0(3),dersc(3))
6416           xtemp(2)=delta
6417           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6418           xtemp(2)=0.0d0
6419           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6420           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6421                   dersc0(2),esclocbi,dersc02)
6422           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6423                   dersc12,dersc01)
6424           dersc0(1)=dersc01
6425           dersc0(2)=dersc02
6426           dersc0(3)=0.0d0
6427           call splinthet(x(2),0.5d0*delta,ss,ssd)
6428           do k=1,3
6429             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6430           enddo
6431           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6432 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6433 !    &             esclocbi,ss,ssd
6434           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6435 !         write (iout,*) escloci
6436         else
6437           call enesc(x,escloci,dersc,ddummy,.false.)
6438         endif
6439
6440         escloc=escloc+escloci
6441         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6442            'escloc',i,escloci
6443 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6444
6445         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6446          wscloc*dersc(1)
6447         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6448         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6449     1   continue
6450       enddo
6451       return
6452       end subroutine esc
6453 !-----------------------------------------------------------------------------
6454       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6455
6456       use comm_sccalc
6457 !      implicit real*8 (a-h,o-z)
6458 !      include 'DIMENSIONS'
6459 !      include 'COMMON.GEO'
6460 !      include 'COMMON.LOCAL'
6461 !      include 'COMMON.IOUNITS'
6462 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6463       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6464       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6465       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6466       real(kind=8) :: escloci
6467       logical :: mixed
6468 !el local variables
6469       integer :: j,iii,l,k !el,it,nlobit
6470       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6471 !el       time11,time12,time112
6472 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6473         escloc_i=0.0D0
6474         do j=1,3
6475           dersc(j)=0.0D0
6476           if (mixed) ddersc(j)=0.0d0
6477         enddo
6478         x3=x(3)
6479
6480 ! Because of periodicity of the dependence of the SC energy in omega we have
6481 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6482 ! To avoid underflows, first compute & store the exponents.
6483
6484         do iii=-1,1
6485
6486           x(3)=x3+iii*dwapi
6487
6488           do j=1,nlobit
6489             do k=1,3
6490               z(k)=x(k)-censc(k,j,it)
6491             enddo
6492             do k=1,3
6493               Axk=0.0D0
6494               do l=1,3
6495                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6496               enddo
6497               Ax(k,j,iii)=Axk
6498             enddo
6499             expfac=0.0D0
6500             do k=1,3
6501               expfac=expfac+Ax(k,j,iii)*z(k)
6502             enddo
6503             contr(j,iii)=expfac
6504           enddo ! j
6505
6506         enddo ! iii
6507
6508         x(3)=x3
6509 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6510 ! subsequent NaNs and INFs in energy calculation.
6511 ! Find the largest exponent
6512         emin=contr(1,-1)
6513         do iii=-1,1
6514           do j=1,nlobit
6515             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6516           enddo
6517         enddo
6518         emin=0.5D0*emin
6519 !d      print *,'it=',it,' emin=',emin
6520
6521 ! Compute the contribution to SC energy and derivatives
6522         do iii=-1,1
6523
6524           do j=1,nlobit
6525 #ifdef OSF
6526             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6527             if(adexp.ne.adexp) adexp=1.0
6528             expfac=dexp(adexp)
6529 #else
6530             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6531 #endif
6532 !d          print *,'j=',j,' expfac=',expfac
6533             escloc_i=escloc_i+expfac
6534             do k=1,3
6535               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6536             enddo
6537             if (mixed) then
6538               do k=1,3,2
6539                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6540                   +gaussc(k,2,j,it))*expfac
6541               enddo
6542             endif
6543           enddo
6544
6545         enddo ! iii
6546
6547         dersc(1)=dersc(1)/cos(theti)**2
6548         ddersc(1)=ddersc(1)/cos(theti)**2
6549         ddersc(3)=ddersc(3)
6550
6551         escloci=-(dlog(escloc_i)-emin)
6552         do j=1,3
6553           dersc(j)=dersc(j)/escloc_i
6554         enddo
6555         if (mixed) then
6556           do j=1,3,2
6557             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6558           enddo
6559         endif
6560       return
6561       end subroutine enesc
6562 !-----------------------------------------------------------------------------
6563       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6564
6565       use comm_sccalc
6566 !      implicit real*8 (a-h,o-z)
6567 !      include 'DIMENSIONS'
6568 !      include 'COMMON.GEO'
6569 !      include 'COMMON.LOCAL'
6570 !      include 'COMMON.IOUNITS'
6571 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6572       real(kind=8),dimension(3) :: x,z,dersc
6573       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6574       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6575       real(kind=8) :: escloci,dersc12,emin
6576       logical :: mixed
6577 !el local varables
6578       integer :: j,k,l !el,it,nlobit
6579       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6580
6581       escloc_i=0.0D0
6582
6583       do j=1,3
6584         dersc(j)=0.0D0
6585       enddo
6586
6587       do j=1,nlobit
6588         do k=1,2
6589           z(k)=x(k)-censc(k,j,it)
6590         enddo
6591         z(3)=dwapi
6592         do k=1,3
6593           Axk=0.0D0
6594           do l=1,3
6595             Axk=Axk+gaussc(l,k,j,it)*z(l)
6596           enddo
6597           Ax(k,j)=Axk
6598         enddo
6599         expfac=0.0D0
6600         do k=1,3
6601           expfac=expfac+Ax(k,j)*z(k)
6602         enddo
6603         contr(j)=expfac
6604       enddo ! j
6605
6606 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6607 ! subsequent NaNs and INFs in energy calculation.
6608 ! Find the largest exponent
6609       emin=contr(1)
6610       do j=1,nlobit
6611         if (emin.gt.contr(j)) emin=contr(j)
6612       enddo
6613       emin=0.5D0*emin
6614
6615 ! Compute the contribution to SC energy and derivatives
6616
6617       dersc12=0.0d0
6618       do j=1,nlobit
6619         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6620         escloc_i=escloc_i+expfac
6621         do k=1,2
6622           dersc(k)=dersc(k)+Ax(k,j)*expfac
6623         enddo
6624         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6625                   +gaussc(1,2,j,it))*expfac
6626         dersc(3)=0.0d0
6627       enddo
6628
6629       dersc(1)=dersc(1)/cos(theti)**2
6630       dersc12=dersc12/cos(theti)**2
6631       escloci=-(dlog(escloc_i)-emin)
6632       do j=1,2
6633         dersc(j)=dersc(j)/escloc_i
6634       enddo
6635       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6636       return
6637       end subroutine enesc_bound
6638 #else
6639 !-----------------------------------------------------------------------------
6640       subroutine esc(escloc)
6641 ! Calculate the local energy of a side chain and its derivatives in the
6642 ! corresponding virtual-bond valence angles THETA and the spherical angles
6643 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6644 ! added by Urszula Kozlowska. 07/11/2007
6645 !
6646       use comm_sccalc
6647 !      implicit real*8 (a-h,o-z)
6648 !      include 'DIMENSIONS'
6649 !      include 'COMMON.GEO'
6650 !      include 'COMMON.LOCAL'
6651 !      include 'COMMON.VAR'
6652 !      include 'COMMON.SCROT'
6653 !      include 'COMMON.INTERACT'
6654 !      include 'COMMON.DERIV'
6655 !      include 'COMMON.CHAIN'
6656 !      include 'COMMON.IOUNITS'
6657 !      include 'COMMON.NAMES'
6658 !      include 'COMMON.FFIELD'
6659 !      include 'COMMON.CONTROL'
6660 !      include 'COMMON.VECTORS'
6661       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6662       real(kind=8),dimension(65) :: x
6663       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6664          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6665       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6666       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6667          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6668 !el local variables
6669       integer :: i,j,k !el,it,nlobit
6670       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6671 !el      real(kind=8) :: time11,time12,time112,theti
6672 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6673       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6674                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6675                    sumene1x,sumene2x,sumene3x,sumene4x,&
6676                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6677                    cosfac2xx,sinfac2yy
6678 #ifdef DEBUG
6679       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6680                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6681                    de_dt_num
6682 #endif
6683 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6684
6685       delta=0.02d0*pi
6686       escloc=0.0D0
6687       do i=loc_start,loc_end
6688         if (itype(i,1).eq.ntyp1) cycle
6689         costtab(i+1) =dcos(theta(i+1))
6690         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6691         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6692         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6693         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6694         cosfac=dsqrt(cosfac2)
6695         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6696         sinfac=dsqrt(sinfac2)
6697         it=iabs(itype(i,1))
6698         if (it.eq.10) goto 1
6699 !
6700 !  Compute the axes of tghe local cartesian coordinates system; store in
6701 !   x_prime, y_prime and z_prime
6702 !
6703         do j=1,3
6704           x_prime(j) = 0.00
6705           y_prime(j) = 0.00
6706           z_prime(j) = 0.00
6707         enddo
6708 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6709 !     &   dc_norm(3,i+nres)
6710         do j = 1,3
6711           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6712           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6713         enddo
6714         do j = 1,3
6715           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6716         enddo
6717 !       write (2,*) "i",i
6718 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6719 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6720 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6721 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6722 !      & " xy",scalar(x_prime(1),y_prime(1)),
6723 !      & " xz",scalar(x_prime(1),z_prime(1)),
6724 !      & " yy",scalar(y_prime(1),y_prime(1)),
6725 !      & " yz",scalar(y_prime(1),z_prime(1)),
6726 !      & " zz",scalar(z_prime(1),z_prime(1))
6727 !
6728 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6729 ! to local coordinate system. Store in xx, yy, zz.
6730 !
6731         xx=0.0d0
6732         yy=0.0d0
6733         zz=0.0d0
6734         do j = 1,3
6735           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6736           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6737           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6738         enddo
6739
6740         xxtab(i)=xx
6741         yytab(i)=yy
6742         zztab(i)=zz
6743 !
6744 ! Compute the energy of the ith side cbain
6745 !
6746 !        write (2,*) "xx",xx," yy",yy," zz",zz
6747         it=iabs(itype(i,1))
6748         do j = 1,65
6749           x(j) = sc_parmin(j,it)
6750         enddo
6751 #ifdef CHECK_COORD
6752 !c diagnostics - remove later
6753         xx1 = dcos(alph(2))
6754         yy1 = dsin(alph(2))*dcos(omeg(2))
6755         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6756         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6757           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6758           xx1,yy1,zz1
6759 !,"  --- ", xx_w,yy_w,zz_w
6760 ! end diagnostics
6761 #endif
6762         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6763          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6764          + x(10)*yy*zz
6765         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6766          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6767          + x(20)*yy*zz
6768         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6769          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6770          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6771          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6772          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6773          +x(40)*xx*yy*zz
6774         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6775          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6776          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6777          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6778          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6779          +x(60)*xx*yy*zz
6780         dsc_i   = 0.743d0+x(61)
6781         dp2_i   = 1.9d0+x(62)
6782         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6783                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6784         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6785                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6786         s1=(1+x(63))/(0.1d0 + dscp1)
6787         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6788         s2=(1+x(65))/(0.1d0 + dscp2)
6789         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6790         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6791       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6792 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6793 !     &   sumene4,
6794 !     &   dscp1,dscp2,sumene
6795 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6796         escloc = escloc + sumene
6797        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6798         " escloc",sumene,escloc,it,itype(i,1)
6799 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6800 !     & ,zz,xx,yy
6801 !#define DEBUG
6802 #ifdef DEBUG
6803 !
6804 ! This section to check the numerical derivatives of the energy of ith side
6805 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6806 ! #define DEBUG in the code to turn it on.
6807 !
6808         write (2,*) "sumene               =",sumene
6809         aincr=1.0d-7
6810         xxsave=xx
6811         xx=xx+aincr
6812         write (2,*) xx,yy,zz
6813         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6814         de_dxx_num=(sumenep-sumene)/aincr
6815         xx=xxsave
6816         write (2,*) "xx+ sumene from enesc=",sumenep
6817         yysave=yy
6818         yy=yy+aincr
6819         write (2,*) xx,yy,zz
6820         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6821         de_dyy_num=(sumenep-sumene)/aincr
6822         yy=yysave
6823         write (2,*) "yy+ sumene from enesc=",sumenep
6824         zzsave=zz
6825         zz=zz+aincr
6826         write (2,*) xx,yy,zz
6827         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6828         de_dzz_num=(sumenep-sumene)/aincr
6829         zz=zzsave
6830         write (2,*) "zz+ sumene from enesc=",sumenep
6831         costsave=cost2tab(i+1)
6832         sintsave=sint2tab(i+1)
6833         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6834         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6835         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6836         de_dt_num=(sumenep-sumene)/aincr
6837         write (2,*) " t+ sumene from enesc=",sumenep
6838         cost2tab(i+1)=costsave
6839         sint2tab(i+1)=sintsave
6840 ! End of diagnostics section.
6841 #endif
6842 !
6843 ! Compute the gradient of esc
6844 !
6845 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6846         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6847         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6848         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6849         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6850         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6851         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6852         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6853         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6854         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6855            *(pom_s1/dscp1+pom_s16*dscp1**4)
6856         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6857            *(pom_s2/dscp2+pom_s26*dscp2**4)
6858         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6859         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6860         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6861         +x(40)*yy*zz
6862         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6863         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6864         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6865         +x(60)*yy*zz
6866         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6867               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6868               +(pom1+pom2)*pom_dx
6869 #ifdef DEBUG
6870         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6871 #endif
6872 !
6873         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6874         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6875         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6876         +x(40)*xx*zz
6877         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6878         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6879         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6880         +x(59)*zz**2 +x(60)*xx*zz
6881         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6882               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6883               +(pom1-pom2)*pom_dy
6884 #ifdef DEBUG
6885         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6886 #endif
6887 !
6888         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6889         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6890         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6891         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6892         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6893         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6894         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6895         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6896 #ifdef DEBUG
6897         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6898 #endif
6899 !
6900         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6901         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6902         +pom1*pom_dt1+pom2*pom_dt2
6903 #ifdef DEBUG
6904         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6905 #endif
6906 !
6907 !
6908        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6909        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6910        cosfac2xx=cosfac2*xx
6911        sinfac2yy=sinfac2*yy
6912        do k = 1,3
6913          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6914             vbld_inv(i+1)
6915          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6916             vbld_inv(i)
6917          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6918          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6919 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6920 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6921 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6922 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6923          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6924          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6925          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6926          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6927          dZZ_Ci1(k)=0.0d0
6928          dZZ_Ci(k)=0.0d0
6929          do j=1,3
6930            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6931            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6932            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6933            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6934          enddo
6935
6936          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6937          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6938          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6939          (z_prime(k)-zz*dC_norm(k,i+nres))
6940 !
6941          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6942          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6943        enddo
6944
6945        do k=1,3
6946          dXX_Ctab(k,i)=dXX_Ci(k)
6947          dXX_C1tab(k,i)=dXX_Ci1(k)
6948          dYY_Ctab(k,i)=dYY_Ci(k)
6949          dYY_C1tab(k,i)=dYY_Ci1(k)
6950          dZZ_Ctab(k,i)=dZZ_Ci(k)
6951          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6952          dXX_XYZtab(k,i)=dXX_XYZ(k)
6953          dYY_XYZtab(k,i)=dYY_XYZ(k)
6954          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6955        enddo
6956
6957        do k = 1,3
6958 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6959 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6960 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6961 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6962 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6963 !     &    dt_dci(k)
6964 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6965 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6966          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6967           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6968          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6969           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6970          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6971           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6972        enddo
6973 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6974 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6975
6976 ! to check gradient call subroutine check_grad
6977
6978     1 continue
6979       enddo
6980       return
6981       end subroutine esc
6982 !-----------------------------------------------------------------------------
6983       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6984 !      implicit none
6985       real(kind=8),dimension(65) :: x
6986       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6987         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6988
6989       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6990         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6991         + x(10)*yy*zz
6992       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6993         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6994         + x(20)*yy*zz
6995       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6996         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6997         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6998         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6999         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7000         +x(40)*xx*yy*zz
7001       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7002         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7003         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7004         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7005         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7006         +x(60)*xx*yy*zz
7007       dsc_i   = 0.743d0+x(61)
7008       dp2_i   = 1.9d0+x(62)
7009       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7010                 *(xx*cost2+yy*sint2))
7011       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7012                 *(xx*cost2-yy*sint2))
7013       s1=(1+x(63))/(0.1d0 + dscp1)
7014       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7015       s2=(1+x(65))/(0.1d0 + dscp2)
7016       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7017       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7018        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7019       enesc=sumene
7020       return
7021       end function enesc
7022 #endif
7023 !-----------------------------------------------------------------------------
7024       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7025 !
7026 ! This procedure calculates two-body contact function g(rij) and its derivative:
7027 !
7028 !           eps0ij                                     !       x < -1
7029 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7030 !            0                                         !       x > 1
7031 !
7032 ! where x=(rij-r0ij)/delta
7033 !
7034 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7035 !
7036 !      implicit none
7037       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7038       real(kind=8) :: x,x2,x4,delta
7039 !     delta=0.02D0*r0ij
7040 !      delta=0.2D0*r0ij
7041       x=(rij-r0ij)/delta
7042       if (x.lt.-1.0D0) then
7043         fcont=eps0ij
7044         fprimcont=0.0D0
7045       else if (x.le.1.0D0) then
7046         x2=x*x
7047         x4=x2*x2
7048         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7049         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7050       else
7051         fcont=0.0D0
7052         fprimcont=0.0D0
7053       endif
7054       return
7055       end subroutine gcont
7056 !-----------------------------------------------------------------------------
7057       subroutine splinthet(theti,delta,ss,ssder)
7058 !      implicit real*8 (a-h,o-z)
7059 !      include 'DIMENSIONS'
7060 !      include 'COMMON.VAR'
7061 !      include 'COMMON.GEO'
7062       real(kind=8) :: theti,delta,ss,ssder
7063       real(kind=8) :: thetup,thetlow
7064       thetup=pi-delta
7065       thetlow=delta
7066       if (theti.gt.pipol) then
7067         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7068       else
7069         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7070         ssder=-ssder
7071       endif
7072       return
7073       end subroutine splinthet
7074 !-----------------------------------------------------------------------------
7075       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7076 !      implicit none
7077       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7078       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7079       a1=fprim0*delta/(f1-f0)
7080       a2=3.0d0-2.0d0*a1
7081       a3=a1-2.0d0
7082       ksi=(x-x0)/delta
7083       ksi2=ksi*ksi
7084       ksi3=ksi2*ksi
7085       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7086       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7087       return
7088       end subroutine spline1
7089 !-----------------------------------------------------------------------------
7090       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7091 !      implicit none
7092       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7093       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7094       ksi=(x-x0)/delta
7095       ksi2=ksi*ksi
7096       ksi3=ksi2*ksi
7097       a1=fprim0x*delta
7098       a2=3*(f1x-f0x)-2*fprim0x*delta
7099       a3=fprim0x*delta-2*(f1x-f0x)
7100       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7101       return
7102       end subroutine spline2
7103 !-----------------------------------------------------------------------------
7104 #ifdef CRYST_TOR
7105 !-----------------------------------------------------------------------------
7106       subroutine etor(etors,edihcnstr)
7107 !      implicit real*8 (a-h,o-z)
7108 !      include 'DIMENSIONS'
7109 !      include 'COMMON.VAR'
7110 !      include 'COMMON.GEO'
7111 !      include 'COMMON.LOCAL'
7112 !      include 'COMMON.TORSION'
7113 !      include 'COMMON.INTERACT'
7114 !      include 'COMMON.DERIV'
7115 !      include 'COMMON.CHAIN'
7116 !      include 'COMMON.NAMES'
7117 !      include 'COMMON.IOUNITS'
7118 !      include 'COMMON.FFIELD'
7119 !      include 'COMMON.TORCNSTR'
7120 !      include 'COMMON.CONTROL'
7121       real(kind=8) :: etors,edihcnstr
7122       logical :: lprn
7123 !el local variables
7124       integer :: i,j,
7125       real(kind=8) :: phii,fac,etors_ii
7126
7127 ! Set lprn=.true. for debugging
7128       lprn=.false.
7129 !      lprn=.true.
7130       etors=0.0D0
7131       do i=iphi_start,iphi_end
7132       etors_ii=0.0D0
7133         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7134             .or. itype(i,1).eq.ntyp1) cycle
7135         itori=itortyp(itype(i-2,1))
7136         itori1=itortyp(itype(i-1,1))
7137         phii=phi(i)
7138         gloci=0.0D0
7139 ! Proline-Proline pair is a special case...
7140         if (itori.eq.3 .and. itori1.eq.3) then
7141           if (phii.gt.-dwapi3) then
7142             cosphi=dcos(3*phii)
7143             fac=1.0D0/(1.0D0-cosphi)
7144             etorsi=v1(1,3,3)*fac
7145             etorsi=etorsi+etorsi
7146             etors=etors+etorsi-v1(1,3,3)
7147             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7148             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7149           endif
7150           do j=1,3
7151             v1ij=v1(j+1,itori,itori1)
7152             v2ij=v2(j+1,itori,itori1)
7153             cosphi=dcos(j*phii)
7154             sinphi=dsin(j*phii)
7155             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7156             if (energy_dec) etors_ii=etors_ii+ &
7157                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7158             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7159           enddo
7160         else
7161           do j=1,nterm_old
7162             v1ij=v1(j,itori,itori1)
7163             v2ij=v2(j,itori,itori1)
7164             cosphi=dcos(j*phii)
7165             sinphi=dsin(j*phii)
7166             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7167             if (energy_dec) etors_ii=etors_ii+ &
7168                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7169             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7170           enddo
7171         endif
7172         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7173              'etor',i,etors_ii
7174         if (lprn) &
7175         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7176         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7177         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7178         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7179 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7180       enddo
7181 ! 6/20/98 - dihedral angle constraints
7182       edihcnstr=0.0d0
7183       do i=1,ndih_constr
7184         itori=idih_constr(i)
7185         phii=phi(itori)
7186         difi=phii-phi0(i)
7187         if (difi.gt.drange(i)) then
7188           difi=difi-drange(i)
7189           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7190           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7191         else if (difi.lt.-drange(i)) then
7192           difi=difi+drange(i)
7193           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7194           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7195         endif
7196 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7197 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7198       enddo
7199 !      write (iout,*) 'edihcnstr',edihcnstr
7200       return
7201       end subroutine etor
7202 !-----------------------------------------------------------------------------
7203       subroutine etor_d(etors_d)
7204       real(kind=8) :: etors_d
7205       etors_d=0.0d0
7206       return
7207       end subroutine etor_d
7208 #else
7209 !-----------------------------------------------------------------------------
7210       subroutine etor(etors)
7211 !      implicit real*8 (a-h,o-z)
7212 !      include 'DIMENSIONS'
7213 !      include 'COMMON.VAR'
7214 !      include 'COMMON.GEO'
7215 !      include 'COMMON.LOCAL'
7216 !      include 'COMMON.TORSION'
7217 !      include 'COMMON.INTERACT'
7218 !      include 'COMMON.DERIV'
7219 !      include 'COMMON.CHAIN'
7220 !      include 'COMMON.NAMES'
7221 !      include 'COMMON.IOUNITS'
7222 !      include 'COMMON.FFIELD'
7223 !      include 'COMMON.TORCNSTR'
7224 !      include 'COMMON.CONTROL'
7225       real(kind=8) :: etors,edihcnstr
7226       logical :: lprn
7227 !el local variables
7228       integer :: i,j,iblock,itori,itori1
7229       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7230                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7231 ! Set lprn=.true. for debugging
7232       lprn=.false.
7233 !     lprn=.true.
7234       etors=0.0D0
7235       do i=iphi_start,iphi_end
7236         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7237              .or. itype(i-3,1).eq.ntyp1 &
7238              .or. itype(i,1).eq.ntyp1) cycle
7239         etors_ii=0.0D0
7240          if (iabs(itype(i,1)).eq.20) then
7241          iblock=2
7242          else
7243          iblock=1
7244          endif
7245         itori=itortyp(itype(i-2,1))
7246         itori1=itortyp(itype(i-1,1))
7247         phii=phi(i)
7248         gloci=0.0D0
7249 ! Regular cosine and sine terms
7250         do j=1,nterm(itori,itori1,iblock)
7251           v1ij=v1(j,itori,itori1,iblock)
7252           v2ij=v2(j,itori,itori1,iblock)
7253           cosphi=dcos(j*phii)
7254           sinphi=dsin(j*phii)
7255           etors=etors+v1ij*cosphi+v2ij*sinphi
7256           if (energy_dec) etors_ii=etors_ii+ &
7257                      v1ij*cosphi+v2ij*sinphi
7258           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7259         enddo
7260 ! Lorentz terms
7261 !                         v1
7262 !  E = SUM ----------------------------------- - v1
7263 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7264 !
7265         cosphi=dcos(0.5d0*phii)
7266         sinphi=dsin(0.5d0*phii)
7267         do j=1,nlor(itori,itori1,iblock)
7268           vl1ij=vlor1(j,itori,itori1)
7269           vl2ij=vlor2(j,itori,itori1)
7270           vl3ij=vlor3(j,itori,itori1)
7271           pom=vl2ij*cosphi+vl3ij*sinphi
7272           pom1=1.0d0/(pom*pom+1.0d0)
7273           etors=etors+vl1ij*pom1
7274           if (energy_dec) etors_ii=etors_ii+ &
7275                      vl1ij*pom1
7276           pom=-pom*pom1*pom1
7277           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7278         enddo
7279 ! Subtract the constant term
7280         etors=etors-v0(itori,itori1,iblock)
7281           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7282                'etor',i,etors_ii-v0(itori,itori1,iblock)
7283         if (lprn) &
7284         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7285         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7286         (v1(j,itori,itori1,iblock),j=1,6),&
7287         (v2(j,itori,itori1,iblock),j=1,6)
7288         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7289 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7290       enddo
7291 ! 6/20/98 - dihedral angle constraints
7292       return
7293       end subroutine etor
7294 !C The rigorous attempt to derive energy function
7295 !-------------------------------------------------------------------------------------------
7296       subroutine etor_kcc(etors)
7297       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7298       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7299        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7300        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7301        gradvalst2,etori
7302       logical lprn
7303       integer :: i,j,itori,itori1,nval,k,l
7304
7305       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7306       etors=0.0D0
7307       do i=iphi_start,iphi_end
7308 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7309 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7310 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7311 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7312         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7313            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7314         itori=itortyp(itype(i-2,1))
7315         itori1=itortyp(itype(i-1,1))
7316         phii=phi(i)
7317         glocig=0.0D0
7318         glocit1=0.0d0
7319         glocit2=0.0d0
7320 !C to avoid multiple devision by 2
7321 !c        theti22=0.5d0*theta(i)
7322 !C theta 12 is the theta_1 /2
7323 !C theta 22 is theta_2 /2
7324 !c        theti12=0.5d0*theta(i-1)
7325 !C and appropriate sinus function
7326         sinthet1=dsin(theta(i-1))
7327         sinthet2=dsin(theta(i))
7328         costhet1=dcos(theta(i-1))
7329         costhet2=dcos(theta(i))
7330 !C to speed up lets store its mutliplication
7331         sint1t2=sinthet2*sinthet1
7332         sint1t2n=1.0d0
7333 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7334 !C +d_n*sin(n*gamma)) *
7335 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7336 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7337         nval=nterm_kcc_Tb(itori,itori1)
7338         c1(0)=0.0d0
7339         c2(0)=0.0d0
7340         c1(1)=1.0d0
7341         c2(1)=1.0d0
7342         do j=2,nval
7343           c1(j)=c1(j-1)*costhet1
7344           c2(j)=c2(j-1)*costhet2
7345         enddo
7346         etori=0.0d0
7347
7348        do j=1,nterm_kcc(itori,itori1)
7349           cosphi=dcos(j*phii)
7350           sinphi=dsin(j*phii)
7351           sint1t2n1=sint1t2n
7352           sint1t2n=sint1t2n*sint1t2
7353           sumvalc=0.0d0
7354           gradvalct1=0.0d0
7355           gradvalct2=0.0d0
7356           do k=1,nval
7357             do l=1,nval
7358               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7359               gradvalct1=gradvalct1+ &
7360                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7361               gradvalct2=gradvalct2+ &
7362                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7363             enddo
7364           enddo
7365           gradvalct1=-gradvalct1*sinthet1
7366           gradvalct2=-gradvalct2*sinthet2
7367           sumvals=0.0d0
7368           gradvalst1=0.0d0
7369           gradvalst2=0.0d0
7370           do k=1,nval
7371             do l=1,nval
7372               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7373               gradvalst1=gradvalst1+ &
7374                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7375               gradvalst2=gradvalst2+ &
7376                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7377             enddo
7378           enddo
7379           gradvalst1=-gradvalst1*sinthet1
7380           gradvalst2=-gradvalst2*sinthet2
7381           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7382           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7383 !C glocig is the gradient local i site in gamma
7384           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7385 !C now gradient over theta_1
7386          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7387         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7388          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7389         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7390         enddo ! j
7391         etors=etors+etori
7392         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7393 !C derivative over theta1
7394         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7395 !C now derivative over theta2
7396         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7397         if (lprn) then
7398          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7399             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7400           write (iout,*) "c1",(c1(k),k=0,nval), &
7401          " c2",(c2(k),k=0,nval)
7402         endif
7403       enddo
7404       return
7405        end  subroutine etor_kcc
7406 !------------------------------------------------------------------------------
7407
7408         subroutine etor_constr(edihcnstr)
7409       real(kind=8) :: etors,edihcnstr
7410       logical :: lprn
7411 !el local variables
7412       integer :: i,j,iblock,itori,itori1
7413       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7414                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7415                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7416
7417       if (raw_psipred) then
7418         do i=idihconstr_start,idihconstr_end
7419           itori=idih_constr(i)
7420           phii=phi(itori)
7421           gaudih_i=vpsipred(1,i)
7422           gauder_i=0.0d0
7423           do j=1,2
7424             s = sdihed(j,i)
7425             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7426             dexpcos_i=dexp(-cos_i*cos_i)
7427             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7428           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7429                  *cos_i*dexpcos_i/s**2
7430           enddo
7431           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7432           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7433           if (energy_dec) &
7434           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7435           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7436           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7437           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7438           -wdihc*dlog(gaudih_i)
7439         enddo
7440       else
7441
7442       do i=idihconstr_start,idihconstr_end
7443         itori=idih_constr(i)
7444         phii=phi(itori)
7445         difi=pinorm(phii-phi0(i))
7446         if (difi.gt.drange(i)) then
7447           difi=difi-drange(i)
7448           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7449           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7450         else if (difi.lt.-drange(i)) then
7451           difi=difi+drange(i)
7452           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7453           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7454         else
7455           difi=0.0
7456         endif
7457       enddo
7458
7459       endif
7460
7461       return
7462
7463       end subroutine etor_constr
7464 !-----------------------------------------------------------------------------
7465       subroutine etor_d(etors_d)
7466 ! 6/23/01 Compute double torsional energy
7467 !      implicit real*8 (a-h,o-z)
7468 !      include 'DIMENSIONS'
7469 !      include 'COMMON.VAR'
7470 !      include 'COMMON.GEO'
7471 !      include 'COMMON.LOCAL'
7472 !      include 'COMMON.TORSION'
7473 !      include 'COMMON.INTERACT'
7474 !      include 'COMMON.DERIV'
7475 !      include 'COMMON.CHAIN'
7476 !      include 'COMMON.NAMES'
7477 !      include 'COMMON.IOUNITS'
7478 !      include 'COMMON.FFIELD'
7479 !      include 'COMMON.TORCNSTR'
7480       real(kind=8) :: etors_d,etors_d_ii
7481       logical :: lprn
7482 !el local variables
7483       integer :: i,j,k,l,itori,itori1,itori2,iblock
7484       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7485                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7486                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7487                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7488 ! Set lprn=.true. for debugging
7489       lprn=.false.
7490 !     lprn=.true.
7491       etors_d=0.0D0
7492 !      write(iout,*) "a tu??"
7493       do i=iphid_start,iphid_end
7494         etors_d_ii=0.0D0
7495         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7496             .or. itype(i-3,1).eq.ntyp1 &
7497             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7498         itori=itortyp(itype(i-2,1))
7499         itori1=itortyp(itype(i-1,1))
7500         itori2=itortyp(itype(i,1))
7501         phii=phi(i)
7502         phii1=phi(i+1)
7503         gloci1=0.0D0
7504         gloci2=0.0D0
7505         iblock=1
7506         if (iabs(itype(i+1,1)).eq.20) iblock=2
7507
7508 ! Regular cosine and sine terms
7509         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7510           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7511           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7512           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7513           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7514           cosphi1=dcos(j*phii)
7515           sinphi1=dsin(j*phii)
7516           cosphi2=dcos(j*phii1)
7517           sinphi2=dsin(j*phii1)
7518           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7519            v2cij*cosphi2+v2sij*sinphi2
7520           if (energy_dec) etors_d_ii=etors_d_ii+ &
7521            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7522           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7523           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7524         enddo
7525         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7526           do l=1,k-1
7527             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7528             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7529             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7530             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7531             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7532             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7533             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7534             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7535             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7536               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7537             if (energy_dec) etors_d_ii=etors_d_ii+ &
7538               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7539               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7540             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7541               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7542             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7543               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7544           enddo
7545         enddo
7546         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7547                             'etor_d',i,etors_d_ii
7548         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7549         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7550       enddo
7551       return
7552       end subroutine etor_d
7553 #endif
7554
7555       subroutine ebend_kcc(etheta)
7556       logical lprn
7557       double precision thybt1(maxang_kcc),etheta
7558       integer :: i,iti,j,ihelp
7559       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7560 !C Set lprn=.true. for debugging
7561       lprn=energy_dec
7562 !c     lprn=.true.
7563 !C      print *,"wchodze kcc"
7564       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7565       etheta=0.0D0
7566       do i=ithet_start,ithet_end
7567 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7568         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7569        .or.itype(i,1).eq.ntyp1) cycle
7570         iti=iabs(itortyp(itype(i-1,1)))
7571         sinthet=dsin(theta(i))
7572         costhet=dcos(theta(i))
7573         do j=1,nbend_kcc_Tb(iti)
7574           thybt1(j)=v1bend_chyb(j,iti)
7575         enddo
7576         sumth1thyb=v1bend_chyb(0,iti)+ &
7577          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7578         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7579          sumth1thyb
7580         ihelp=nbend_kcc_Tb(iti)-1
7581         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7582         etheta=etheta+sumth1thyb
7583 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7584         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7585       enddo
7586       return
7587       end subroutine ebend_kcc
7588 !c------------
7589 !c-------------------------------------------------------------------------------------
7590       subroutine etheta_constr(ethetacnstr)
7591       real (kind=8) :: ethetacnstr,thetiii,difi
7592       integer :: i,itheta
7593       ethetacnstr=0.0d0
7594 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7595       do i=ithetaconstr_start,ithetaconstr_end
7596         itheta=itheta_constr(i)
7597         thetiii=theta(itheta)
7598         difi=pinorm(thetiii-theta_constr0(i))
7599         if (difi.gt.theta_drange(i)) then
7600           difi=difi-theta_drange(i)
7601           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7602           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7603          +for_thet_constr(i)*difi**3
7604         else if (difi.lt.-drange(i)) then
7605           difi=difi+drange(i)
7606           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7607           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7608           +for_thet_constr(i)*difi**3
7609         else
7610           difi=0.0
7611         endif
7612        if (energy_dec) then
7613         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7614          i,itheta,rad2deg*thetiii,&
7615          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7616          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7617          gloc(itheta+nphi-2,icg)
7618         endif
7619       enddo
7620       return
7621       end subroutine etheta_constr
7622
7623 !-----------------------------------------------------------------------------
7624       subroutine eback_sc_corr(esccor)
7625 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7626 !        conformational states; temporarily implemented as differences
7627 !        between UNRES torsional potentials (dependent on three types of
7628 !        residues) and the torsional potentials dependent on all 20 types
7629 !        of residues computed from AM1  energy surfaces of terminally-blocked
7630 !        amino-acid residues.
7631 !      implicit real*8 (a-h,o-z)
7632 !      include 'DIMENSIONS'
7633 !      include 'COMMON.VAR'
7634 !      include 'COMMON.GEO'
7635 !      include 'COMMON.LOCAL'
7636 !      include 'COMMON.TORSION'
7637 !      include 'COMMON.SCCOR'
7638 !      include 'COMMON.INTERACT'
7639 !      include 'COMMON.DERIV'
7640 !      include 'COMMON.CHAIN'
7641 !      include 'COMMON.NAMES'
7642 !      include 'COMMON.IOUNITS'
7643 !      include 'COMMON.FFIELD'
7644 !      include 'COMMON.CONTROL'
7645       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7646                    cosphi,sinphi
7647       logical :: lprn
7648       integer :: i,interty,j,isccori,isccori1,intertyp
7649 ! Set lprn=.true. for debugging
7650       lprn=.false.
7651 !      lprn=.true.
7652 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7653       esccor=0.0D0
7654       do i=itau_start,itau_end
7655         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7656         esccor_ii=0.0D0
7657         isccori=isccortyp(itype(i-2,1))
7658         isccori1=isccortyp(itype(i-1,1))
7659
7660 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7661         phii=phi(i)
7662         do intertyp=1,3 !intertyp
7663          esccor_ii=0.0D0
7664 !c Added 09 May 2012 (Adasko)
7665 !c  Intertyp means interaction type of backbone mainchain correlation:
7666 !   1 = SC...Ca...Ca...Ca
7667 !   2 = Ca...Ca...Ca...SC
7668 !   3 = SC...Ca...Ca...SCi
7669         gloci=0.0D0
7670         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7671             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7672             (itype(i-1,1).eq.ntyp1))) &
7673           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7674            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7675            .or.(itype(i,1).eq.ntyp1))) &
7676           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7677             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7678             (itype(i-3,1).eq.ntyp1)))) cycle
7679         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7680         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7681        cycle
7682        do j=1,nterm_sccor(isccori,isccori1)
7683           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7684           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7685           cosphi=dcos(j*tauangle(intertyp,i))
7686           sinphi=dsin(j*tauangle(intertyp,i))
7687           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7688           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7689           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7690         enddo
7691         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7692                                 'esccor',i,intertyp,esccor_ii
7693 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7694         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7695         if (lprn) &
7696         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7697         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7698         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7699         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7700         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7701        enddo !intertyp
7702       enddo
7703
7704       return
7705       end subroutine eback_sc_corr
7706 !-----------------------------------------------------------------------------
7707       subroutine multibody(ecorr)
7708 ! This subroutine calculates multi-body contributions to energy following
7709 ! the idea of Skolnick et al. If side chains I and J make a contact and
7710 ! at the same time side chains I+1 and J+1 make a contact, an extra
7711 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7712 !      implicit real*8 (a-h,o-z)
7713 !      include 'DIMENSIONS'
7714 !      include 'COMMON.IOUNITS'
7715 !      include 'COMMON.DERIV'
7716 !      include 'COMMON.INTERACT'
7717 !      include 'COMMON.CONTACTS'
7718       real(kind=8),dimension(3) :: gx,gx1
7719       logical :: lprn
7720       real(kind=8) :: ecorr
7721       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7722 ! Set lprn=.true. for debugging
7723       lprn=.false.
7724
7725       if (lprn) then
7726         write (iout,'(a)') 'Contact function values:'
7727         do i=nnt,nct-2
7728           write (iout,'(i2,20(1x,i2,f10.5))') &
7729               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7730         enddo
7731       endif
7732       ecorr=0.0D0
7733
7734 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7735 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7736       do i=nnt,nct
7737         do j=1,3
7738           gradcorr(j,i)=0.0D0
7739           gradxorr(j,i)=0.0D0
7740         enddo
7741       enddo
7742       do i=nnt,nct-2
7743
7744         DO ISHIFT = 3,4
7745
7746         i1=i+ishift
7747         num_conti=num_cont(i)
7748         num_conti1=num_cont(i1)
7749         do jj=1,num_conti
7750           j=jcont(jj,i)
7751           do kk=1,num_conti1
7752             j1=jcont(kk,i1)
7753             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7754 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7755 !d   &                   ' ishift=',ishift
7756 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7757 ! The system gains extra energy.
7758               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7759             endif   ! j1==j+-ishift
7760           enddo     ! kk
7761         enddo       ! jj
7762
7763         ENDDO ! ISHIFT
7764
7765       enddo         ! i
7766       return
7767       end subroutine multibody
7768 !-----------------------------------------------------------------------------
7769       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7770 !      implicit real*8 (a-h,o-z)
7771 !      include 'DIMENSIONS'
7772 !      include 'COMMON.IOUNITS'
7773 !      include 'COMMON.DERIV'
7774 !      include 'COMMON.INTERACT'
7775 !      include 'COMMON.CONTACTS'
7776       real(kind=8),dimension(3) :: gx,gx1
7777       logical :: lprn
7778       integer :: i,j,k,l,jj,kk,m,ll
7779       real(kind=8) :: eij,ekl
7780       lprn=.false.
7781       eij=facont(jj,i)
7782       ekl=facont(kk,k)
7783 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7784 ! Calculate the multi-body contribution to energy.
7785 ! Calculate multi-body contributions to the gradient.
7786 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7787 !d   & k,l,(gacont(m,kk,k),m=1,3)
7788       do m=1,3
7789         gx(m) =ekl*gacont(m,jj,i)
7790         gx1(m)=eij*gacont(m,kk,k)
7791         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7792         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7793         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7794         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7795       enddo
7796       do m=i,j-1
7797         do ll=1,3
7798           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7799         enddo
7800       enddo
7801       do m=k,l-1
7802         do ll=1,3
7803           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7804         enddo
7805       enddo
7806       esccorr=-eij*ekl
7807       return
7808       end function esccorr
7809 !-----------------------------------------------------------------------------
7810       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7811 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7812 !      implicit real*8 (a-h,o-z)
7813 !      include 'DIMENSIONS'
7814 !      include 'COMMON.IOUNITS'
7815 #ifdef MPI
7816       include "mpif.h"
7817 !      integer :: maxconts !max_cont=maxconts  =nres/4
7818       integer,parameter :: max_dim=26
7819       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7820       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7821 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7822 !el      common /przechowalnia/ zapas
7823       integer :: status(MPI_STATUS_SIZE)
7824       integer,dimension((nres/4)*2) :: req !maxconts*2
7825       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7826 #endif
7827 !      include 'COMMON.SETUP'
7828 !      include 'COMMON.FFIELD'
7829 !      include 'COMMON.DERIV'
7830 !      include 'COMMON.INTERACT'
7831 !      include 'COMMON.CONTACTS'
7832 !      include 'COMMON.CONTROL'
7833 !      include 'COMMON.LOCAL'
7834       real(kind=8),dimension(3) :: gx,gx1
7835       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7836       logical :: lprn,ldone
7837 !el local variables
7838       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7839               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7840
7841 ! Set lprn=.true. for debugging
7842       lprn=.false.
7843 #ifdef MPI
7844 !      maxconts=nres/4
7845       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7846       n_corr=0
7847       n_corr1=0
7848       if (nfgtasks.le.1) goto 30
7849       if (lprn) then
7850         write (iout,'(a)') 'Contact function values before RECEIVE:'
7851         do i=nnt,nct-2
7852           write (iout,'(2i3,50(1x,i2,f5.2))') &
7853           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7854           j=1,num_cont_hb(i))
7855         enddo
7856       endif
7857       call flush(iout)
7858       do i=1,ntask_cont_from
7859         ncont_recv(i)=0
7860       enddo
7861       do i=1,ntask_cont_to
7862         ncont_sent(i)=0
7863       enddo
7864 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7865 !     & ntask_cont_to
7866 ! Make the list of contacts to send to send to other procesors
7867 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7868 !      call flush(iout)
7869       do i=iturn3_start,iturn3_end
7870 !        write (iout,*) "make contact list turn3",i," num_cont",
7871 !     &    num_cont_hb(i)
7872         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7873       enddo
7874       do i=iturn4_start,iturn4_end
7875 !        write (iout,*) "make contact list turn4",i," num_cont",
7876 !     &   num_cont_hb(i)
7877         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7878       enddo
7879       do ii=1,nat_sent
7880         i=iat_sent(ii)
7881 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7882 !     &    num_cont_hb(i)
7883         do j=1,num_cont_hb(i)
7884         do k=1,4
7885           jjc=jcont_hb(j,i)
7886           iproc=iint_sent_local(k,jjc,ii)
7887 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7888           if (iproc.gt.0) then
7889             ncont_sent(iproc)=ncont_sent(iproc)+1
7890             nn=ncont_sent(iproc)
7891             zapas(1,nn,iproc)=i
7892             zapas(2,nn,iproc)=jjc
7893             zapas(3,nn,iproc)=facont_hb(j,i)
7894             zapas(4,nn,iproc)=ees0p(j,i)
7895             zapas(5,nn,iproc)=ees0m(j,i)
7896             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7897             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7898             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7899             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7900             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7901             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7902             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7903             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7904             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7905             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7906             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7907             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7908             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7909             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7910             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7911             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7912             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7913             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7914             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7915             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7916             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7917           endif
7918         enddo
7919         enddo
7920       enddo
7921       if (lprn) then
7922       write (iout,*) &
7923         "Numbers of contacts to be sent to other processors",&
7924         (ncont_sent(i),i=1,ntask_cont_to)
7925       write (iout,*) "Contacts sent"
7926       do ii=1,ntask_cont_to
7927         nn=ncont_sent(ii)
7928         iproc=itask_cont_to(ii)
7929         write (iout,*) nn," contacts to processor",iproc,&
7930          " of CONT_TO_COMM group"
7931         do i=1,nn
7932           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7933         enddo
7934       enddo
7935       call flush(iout)
7936       endif
7937       CorrelType=477
7938       CorrelID=fg_rank+1
7939       CorrelType1=478
7940       CorrelID1=nfgtasks+fg_rank+1
7941       ireq=0
7942 ! Receive the numbers of needed contacts from other processors
7943       do ii=1,ntask_cont_from
7944         iproc=itask_cont_from(ii)
7945         ireq=ireq+1
7946         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7947           FG_COMM,req(ireq),IERR)
7948       enddo
7949 !      write (iout,*) "IRECV ended"
7950 !      call flush(iout)
7951 ! Send the number of contacts needed by other processors
7952       do ii=1,ntask_cont_to
7953         iproc=itask_cont_to(ii)
7954         ireq=ireq+1
7955         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7956           FG_COMM,req(ireq),IERR)
7957       enddo
7958 !      write (iout,*) "ISEND ended"
7959 !      write (iout,*) "number of requests (nn)",ireq
7960       call flush(iout)
7961       if (ireq.gt.0) &
7962         call MPI_Waitall(ireq,req,status_array,ierr)
7963 !      write (iout,*)
7964 !     &  "Numbers of contacts to be received from other processors",
7965 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7966 !      call flush(iout)
7967 ! Receive contacts
7968       ireq=0
7969       do ii=1,ntask_cont_from
7970         iproc=itask_cont_from(ii)
7971         nn=ncont_recv(ii)
7972 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7973 !     &   " of CONT_TO_COMM group"
7974         call flush(iout)
7975         if (nn.gt.0) then
7976           ireq=ireq+1
7977           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7978           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7979 !          write (iout,*) "ireq,req",ireq,req(ireq)
7980         endif
7981       enddo
7982 ! Send the contacts to processors that need them
7983       do ii=1,ntask_cont_to
7984         iproc=itask_cont_to(ii)
7985         nn=ncont_sent(ii)
7986 !        write (iout,*) nn," contacts to processor",iproc,
7987 !     &   " of CONT_TO_COMM group"
7988         if (nn.gt.0) then
7989           ireq=ireq+1
7990           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7991             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7992 !          write (iout,*) "ireq,req",ireq,req(ireq)
7993 !          do i=1,nn
7994 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7995 !          enddo
7996         endif
7997       enddo
7998 !      write (iout,*) "number of requests (contacts)",ireq
7999 !      write (iout,*) "req",(req(i),i=1,4)
8000 !      call flush(iout)
8001       if (ireq.gt.0) &
8002        call MPI_Waitall(ireq,req,status_array,ierr)
8003       do iii=1,ntask_cont_from
8004         iproc=itask_cont_from(iii)
8005         nn=ncont_recv(iii)
8006         if (lprn) then
8007         write (iout,*) "Received",nn," contacts from processor",iproc,&
8008          " of CONT_FROM_COMM group"
8009         call flush(iout)
8010         do i=1,nn
8011           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8012         enddo
8013         call flush(iout)
8014         endif
8015         do i=1,nn
8016           ii=zapas_recv(1,i,iii)
8017 ! Flag the received contacts to prevent double-counting
8018           jj=-zapas_recv(2,i,iii)
8019 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8020 !          call flush(iout)
8021           nnn=num_cont_hb(ii)+1
8022           num_cont_hb(ii)=nnn
8023           jcont_hb(nnn,ii)=jj
8024           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8025           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8026           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8027           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8028           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8029           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8030           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8031           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8032           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8033           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8034           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8035           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8036           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8037           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8038           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8039           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8040           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8041           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8042           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8043           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8044           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8045           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8046           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8047           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8048         enddo
8049       enddo
8050       call flush(iout)
8051       if (lprn) then
8052         write (iout,'(a)') 'Contact function values after receive:'
8053         do i=nnt,nct-2
8054           write (iout,'(2i3,50(1x,i3,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         call flush(iout)
8059       endif
8060    30 continue
8061 #endif
8062       if (lprn) then
8063         write (iout,'(a)') 'Contact function values:'
8064         do i=nnt,nct-2
8065           write (iout,'(2i3,50(1x,i3,f5.2))') &
8066           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8067           j=1,num_cont_hb(i))
8068         enddo
8069       endif
8070       ecorr=0.0D0
8071
8072 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8073 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8074 ! Remove the loop below after debugging !!!
8075       do i=nnt,nct
8076         do j=1,3
8077           gradcorr(j,i)=0.0D0
8078           gradxorr(j,i)=0.0D0
8079         enddo
8080       enddo
8081 ! Calculate the local-electrostatic correlation terms
8082       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8083         i1=i+1
8084         num_conti=num_cont_hb(i)
8085         num_conti1=num_cont_hb(i+1)
8086         do jj=1,num_conti
8087           j=jcont_hb(jj,i)
8088           jp=iabs(j)
8089           do kk=1,num_conti1
8090             j1=jcont_hb(kk,i1)
8091             jp1=iabs(j1)
8092 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8093 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8094             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8095                 .or. j.lt.0 .and. j1.gt.0) .and. &
8096                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8097 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8098 ! The system gains extra energy.
8099               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8100               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8101                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8102               n_corr=n_corr+1
8103             else if (j1.eq.j) then
8104 ! Contacts I-J and I-(J+1) occur simultaneously.
8105 ! The system loses extra energy.
8106 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8107             endif
8108           enddo ! kk
8109           do kk=1,num_conti
8110             j1=jcont_hb(kk,i)
8111 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8112 !    &         ' jj=',jj,' kk=',kk
8113             if (j1.eq.j+1) then
8114 ! Contacts I-J and (I+1)-J occur simultaneously.
8115 ! The system loses extra energy.
8116 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8117             endif ! j1==j+1
8118           enddo ! kk
8119         enddo ! jj
8120       enddo ! i
8121       return
8122       end subroutine multibody_hb
8123 !-----------------------------------------------------------------------------
8124       subroutine add_hb_contact(ii,jj,itask)
8125 !      implicit real*8 (a-h,o-z)
8126 !      include "DIMENSIONS"
8127 !      include "COMMON.IOUNITS"
8128 !      include "COMMON.CONTACTS"
8129 !      integer,parameter :: maxconts=nres/4
8130       integer,parameter :: max_dim=26
8131       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8132 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8133 !      common /przechowalnia/ zapas
8134       integer :: i,j,ii,jj,iproc,nn,jjc
8135       integer,dimension(4) :: itask
8136 !      write (iout,*) "itask",itask
8137       do i=1,2
8138         iproc=itask(i)
8139         if (iproc.gt.0) then
8140           do j=1,num_cont_hb(ii)
8141             jjc=jcont_hb(j,ii)
8142 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8143             if (jjc.eq.jj) then
8144               ncont_sent(iproc)=ncont_sent(iproc)+1
8145               nn=ncont_sent(iproc)
8146               zapas(1,nn,iproc)=ii
8147               zapas(2,nn,iproc)=jjc
8148               zapas(3,nn,iproc)=facont_hb(j,ii)
8149               zapas(4,nn,iproc)=ees0p(j,ii)
8150               zapas(5,nn,iproc)=ees0m(j,ii)
8151               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8152               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8153               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8154               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8155               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8156               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8157               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8158               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8159               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8160               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8161               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8162               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8163               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8164               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8165               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8166               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8167               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8168               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8169               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8170               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8171               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8172               exit
8173             endif
8174           enddo
8175         endif
8176       enddo
8177       return
8178       end subroutine add_hb_contact
8179 !-----------------------------------------------------------------------------
8180       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8181 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8182 !      implicit real*8 (a-h,o-z)
8183 !      include 'DIMENSIONS'
8184 !      include 'COMMON.IOUNITS'
8185       integer,parameter :: max_dim=70
8186 #ifdef MPI
8187       include "mpif.h"
8188 !      integer :: maxconts !max_cont=maxconts=nres/4
8189       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8190       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8191 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8192 !      common /przechowalnia/ zapas
8193       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8194         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8195         ierr,iii,nnn
8196 #endif
8197 !      include 'COMMON.SETUP'
8198 !      include 'COMMON.FFIELD'
8199 !      include 'COMMON.DERIV'
8200 !      include 'COMMON.LOCAL'
8201 !      include 'COMMON.INTERACT'
8202 !      include 'COMMON.CONTACTS'
8203 !      include 'COMMON.CHAIN'
8204 !      include 'COMMON.CONTROL'
8205       real(kind=8),dimension(3) :: gx,gx1
8206       integer,dimension(nres) :: num_cont_hb_old
8207       logical :: lprn,ldone
8208 !EL      double precision eello4,eello5,eelo6,eello_turn6
8209 !EL      external eello4,eello5,eello6,eello_turn6
8210 !el local variables
8211       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8212               j1,jp1,i1,num_conti1
8213       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8214       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8215
8216 ! Set lprn=.true. for debugging
8217       lprn=.false.
8218       eturn6=0.0d0
8219 #ifdef MPI
8220 !      maxconts=nres/4
8221       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8222       do i=1,nres
8223         num_cont_hb_old(i)=num_cont_hb(i)
8224       enddo
8225       n_corr=0
8226       n_corr1=0
8227       if (nfgtasks.le.1) goto 30
8228       if (lprn) then
8229         write (iout,'(a)') 'Contact function values before RECEIVE:'
8230         do i=nnt,nct-2
8231           write (iout,'(2i3,50(1x,i2,f5.2))') &
8232           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8233           j=1,num_cont_hb(i))
8234         enddo
8235       endif
8236       call flush(iout)
8237       do i=1,ntask_cont_from
8238         ncont_recv(i)=0
8239       enddo
8240       do i=1,ntask_cont_to
8241         ncont_sent(i)=0
8242       enddo
8243 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8244 !     & ntask_cont_to
8245 ! Make the list of contacts to send to send to other procesors
8246       do i=iturn3_start,iturn3_end
8247 !        write (iout,*) "make contact list turn3",i," num_cont",
8248 !     &    num_cont_hb(i)
8249         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8250       enddo
8251       do i=iturn4_start,iturn4_end
8252 !        write (iout,*) "make contact list turn4",i," num_cont",
8253 !     &   num_cont_hb(i)
8254         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8255       enddo
8256       do ii=1,nat_sent
8257         i=iat_sent(ii)
8258 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8259 !     &    num_cont_hb(i)
8260         do j=1,num_cont_hb(i)
8261         do k=1,4
8262           jjc=jcont_hb(j,i)
8263           iproc=iint_sent_local(k,jjc,ii)
8264 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8265           if (iproc.ne.0) then
8266             ncont_sent(iproc)=ncont_sent(iproc)+1
8267             nn=ncont_sent(iproc)
8268             zapas(1,nn,iproc)=i
8269             zapas(2,nn,iproc)=jjc
8270             zapas(3,nn,iproc)=d_cont(j,i)
8271             ind=3
8272             do kk=1,3
8273               ind=ind+1
8274               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8275             enddo
8276             do kk=1,2
8277               do ll=1,2
8278                 ind=ind+1
8279                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8280               enddo
8281             enddo
8282             do jj=1,5
8283               do kk=1,3
8284                 do ll=1,2
8285                   do mm=1,2
8286                     ind=ind+1
8287                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8288                   enddo
8289                 enddo
8290               enddo
8291             enddo
8292           endif
8293         enddo
8294         enddo
8295       enddo
8296       if (lprn) then
8297       write (iout,*) &
8298         "Numbers of contacts to be sent to other processors",&
8299         (ncont_sent(i),i=1,ntask_cont_to)
8300       write (iout,*) "Contacts sent"
8301       do ii=1,ntask_cont_to
8302         nn=ncont_sent(ii)
8303         iproc=itask_cont_to(ii)
8304         write (iout,*) nn," contacts to processor",iproc,&
8305          " of CONT_TO_COMM group"
8306         do i=1,nn
8307           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8308         enddo
8309       enddo
8310       call flush(iout)
8311       endif
8312       CorrelType=477
8313       CorrelID=fg_rank+1
8314       CorrelType1=478
8315       CorrelID1=nfgtasks+fg_rank+1
8316       ireq=0
8317 ! Receive the numbers of needed contacts from other processors
8318       do ii=1,ntask_cont_from
8319         iproc=itask_cont_from(ii)
8320         ireq=ireq+1
8321         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8322           FG_COMM,req(ireq),IERR)
8323       enddo
8324 !      write (iout,*) "IRECV ended"
8325 !      call flush(iout)
8326 ! Send the number of contacts needed by other processors
8327       do ii=1,ntask_cont_to
8328         iproc=itask_cont_to(ii)
8329         ireq=ireq+1
8330         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8331           FG_COMM,req(ireq),IERR)
8332       enddo
8333 !      write (iout,*) "ISEND ended"
8334 !      write (iout,*) "number of requests (nn)",ireq
8335       call flush(iout)
8336       if (ireq.gt.0) &
8337         call MPI_Waitall(ireq,req,status_array,ierr)
8338 !      write (iout,*)
8339 !     &  "Numbers of contacts to be received from other processors",
8340 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8341 !      call flush(iout)
8342 ! Receive contacts
8343       ireq=0
8344       do ii=1,ntask_cont_from
8345         iproc=itask_cont_from(ii)
8346         nn=ncont_recv(ii)
8347 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8348 !     &   " of CONT_TO_COMM group"
8349         call flush(iout)
8350         if (nn.gt.0) then
8351           ireq=ireq+1
8352           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8353           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8354 !          write (iout,*) "ireq,req",ireq,req(ireq)
8355         endif
8356       enddo
8357 ! Send the contacts to processors that need them
8358       do ii=1,ntask_cont_to
8359         iproc=itask_cont_to(ii)
8360         nn=ncont_sent(ii)
8361 !        write (iout,*) nn," contacts to processor",iproc,
8362 !     &   " of CONT_TO_COMM group"
8363         if (nn.gt.0) then
8364           ireq=ireq+1
8365           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8366             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8367 !          write (iout,*) "ireq,req",ireq,req(ireq)
8368 !          do i=1,nn
8369 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8370 !          enddo
8371         endif
8372       enddo
8373 !      write (iout,*) "number of requests (contacts)",ireq
8374 !      write (iout,*) "req",(req(i),i=1,4)
8375 !      call flush(iout)
8376       if (ireq.gt.0) &
8377        call MPI_Waitall(ireq,req,status_array,ierr)
8378       do iii=1,ntask_cont_from
8379         iproc=itask_cont_from(iii)
8380         nn=ncont_recv(iii)
8381         if (lprn) then
8382         write (iout,*) "Received",nn," contacts from processor",iproc,&
8383          " of CONT_FROM_COMM group"
8384         call flush(iout)
8385         do i=1,nn
8386           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8387         enddo
8388         call flush(iout)
8389         endif
8390         do i=1,nn
8391           ii=zapas_recv(1,i,iii)
8392 ! Flag the received contacts to prevent double-counting
8393           jj=-zapas_recv(2,i,iii)
8394 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8395 !          call flush(iout)
8396           nnn=num_cont_hb(ii)+1
8397           num_cont_hb(ii)=nnn
8398           jcont_hb(nnn,ii)=jj
8399           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8400           ind=3
8401           do kk=1,3
8402             ind=ind+1
8403             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8404           enddo
8405           do kk=1,2
8406             do ll=1,2
8407               ind=ind+1
8408               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8409             enddo
8410           enddo
8411           do jj=1,5
8412             do kk=1,3
8413               do ll=1,2
8414                 do mm=1,2
8415                   ind=ind+1
8416                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8417                 enddo
8418               enddo
8419             enddo
8420           enddo
8421         enddo
8422       enddo
8423       call flush(iout)
8424       if (lprn) then
8425         write (iout,'(a)') 'Contact function values after receive:'
8426         do i=nnt,nct-2
8427           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8428           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8429           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8430         enddo
8431         call flush(iout)
8432       endif
8433    30 continue
8434 #endif
8435       if (lprn) then
8436         write (iout,'(a)') 'Contact function values:'
8437         do i=nnt,nct-2
8438           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8439           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8440           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8441         enddo
8442       endif
8443       ecorr=0.0D0
8444       ecorr5=0.0d0
8445       ecorr6=0.0d0
8446
8447 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8448 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8449 ! Remove the loop below after debugging !!!
8450       do i=nnt,nct
8451         do j=1,3
8452           gradcorr(j,i)=0.0D0
8453           gradxorr(j,i)=0.0D0
8454         enddo
8455       enddo
8456 ! Calculate the dipole-dipole interaction energies
8457       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8458       do i=iatel_s,iatel_e+1
8459         num_conti=num_cont_hb(i)
8460         do jj=1,num_conti
8461           j=jcont_hb(jj,i)
8462 #ifdef MOMENT
8463           call dipole(i,j,jj)
8464 #endif
8465         enddo
8466       enddo
8467       endif
8468 ! Calculate the local-electrostatic correlation terms
8469 !                write (iout,*) "gradcorr5 in eello5 before loop"
8470 !                do iii=1,nres
8471 !                  write (iout,'(i5,3f10.5)')
8472 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8473 !                enddo
8474       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8475 !        write (iout,*) "corr loop i",i
8476         i1=i+1
8477         num_conti=num_cont_hb(i)
8478         num_conti1=num_cont_hb(i+1)
8479         do jj=1,num_conti
8480           j=jcont_hb(jj,i)
8481           jp=iabs(j)
8482           do kk=1,num_conti1
8483             j1=jcont_hb(kk,i1)
8484             jp1=iabs(j1)
8485 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8486 !     &         ' jj=',jj,' kk=',kk
8487 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8488             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8489                 .or. j.lt.0 .and. j1.gt.0) .and. &
8490                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8491 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8492 ! The system gains extra energy.
8493               n_corr=n_corr+1
8494               sqd1=dsqrt(d_cont(jj,i))
8495               sqd2=dsqrt(d_cont(kk,i1))
8496               sred_geom = sqd1*sqd2
8497               IF (sred_geom.lt.cutoff_corr) THEN
8498                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8499                   ekont,fprimcont)
8500 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8501 !d     &         ' jj=',jj,' kk=',kk
8502                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8503                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8504                 do l=1,3
8505                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8506                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8507                 enddo
8508                 n_corr1=n_corr1+1
8509 !d               write (iout,*) 'sred_geom=',sred_geom,
8510 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8511 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8512 !d               write (iout,*) "g_contij",g_contij
8513 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8514 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8515                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8516                 if (wcorr4.gt.0.0d0) &
8517                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8518                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8519                        write (iout,'(a6,4i5,0pf7.3)') &
8520                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8521 !                write (iout,*) "gradcorr5 before eello5"
8522 !                do iii=1,nres
8523 !                  write (iout,'(i5,3f10.5)')
8524 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8525 !                enddo
8526                 if (wcorr5.gt.0.0d0) &
8527                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8528 !                write (iout,*) "gradcorr5 after eello5"
8529 !                do iii=1,nres
8530 !                  write (iout,'(i5,3f10.5)')
8531 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8532 !                enddo
8533                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8534                        write (iout,'(a6,4i5,0pf7.3)') &
8535                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8536 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8537 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8538                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8539                      .or. wturn6.eq.0.0d0))then
8540 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8541                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8542                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8543                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8544 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8545 !d     &            'ecorr6=',ecorr6
8546 !d                write (iout,'(4e15.5)') sred_geom,
8547 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8548 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8549 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8550                 else if (wturn6.gt.0.0d0 &
8551                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8552 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8553                   eturn6=eturn6+eello_turn6(i,jj,kk)
8554                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8555                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8556 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8557                 endif
8558               ENDIF
8559 1111          continue
8560             endif
8561           enddo ! kk
8562         enddo ! jj
8563       enddo ! i
8564       do i=1,nres
8565         num_cont_hb(i)=num_cont_hb_old(i)
8566       enddo
8567 !                write (iout,*) "gradcorr5 in eello5"
8568 !                do iii=1,nres
8569 !                  write (iout,'(i5,3f10.5)')
8570 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8571 !                enddo
8572       return
8573       end subroutine multibody_eello
8574 !-----------------------------------------------------------------------------
8575       subroutine add_hb_contact_eello(ii,jj,itask)
8576 !      implicit real*8 (a-h,o-z)
8577 !      include "DIMENSIONS"
8578 !      include "COMMON.IOUNITS"
8579 !      include "COMMON.CONTACTS"
8580 !      integer,parameter :: maxconts=nres/4
8581       integer,parameter :: max_dim=70
8582       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8583 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8584 !      common /przechowalnia/ zapas
8585
8586       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8587       integer,dimension(4) ::itask
8588 !      write (iout,*) "itask",itask
8589       do i=1,2
8590         iproc=itask(i)
8591         if (iproc.gt.0) then
8592           do j=1,num_cont_hb(ii)
8593             jjc=jcont_hb(j,ii)
8594 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8595             if (jjc.eq.jj) then
8596               ncont_sent(iproc)=ncont_sent(iproc)+1
8597               nn=ncont_sent(iproc)
8598               zapas(1,nn,iproc)=ii
8599               zapas(2,nn,iproc)=jjc
8600               zapas(3,nn,iproc)=d_cont(j,ii)
8601               ind=3
8602               do kk=1,3
8603                 ind=ind+1
8604                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8605               enddo
8606               do kk=1,2
8607                 do ll=1,2
8608                   ind=ind+1
8609                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8610                 enddo
8611               enddo
8612               do jj=1,5
8613                 do kk=1,3
8614                   do ll=1,2
8615                     do mm=1,2
8616                       ind=ind+1
8617                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8618                     enddo
8619                   enddo
8620                 enddo
8621               enddo
8622               exit
8623             endif
8624           enddo
8625         endif
8626       enddo
8627       return
8628       end subroutine add_hb_contact_eello
8629 !-----------------------------------------------------------------------------
8630       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8631 !      implicit real*8 (a-h,o-z)
8632 !      include 'DIMENSIONS'
8633 !      include 'COMMON.IOUNITS'
8634 !      include 'COMMON.DERIV'
8635 !      include 'COMMON.INTERACT'
8636 !      include 'COMMON.CONTACTS'
8637       real(kind=8),dimension(3) :: gx,gx1
8638       logical :: lprn
8639 !el local variables
8640       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8641       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8642                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8643                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8644                    rlocshield
8645
8646       lprn=.false.
8647       eij=facont_hb(jj,i)
8648       ekl=facont_hb(kk,k)
8649       ees0pij=ees0p(jj,i)
8650       ees0pkl=ees0p(kk,k)
8651       ees0mij=ees0m(jj,i)
8652       ees0mkl=ees0m(kk,k)
8653       ekont=eij*ekl
8654       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8655 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8656 ! Following 4 lines for diagnostics.
8657 !d    ees0pkl=0.0D0
8658 !d    ees0pij=1.0D0
8659 !d    ees0mkl=0.0D0
8660 !d    ees0mij=1.0D0
8661 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8662 !     & 'Contacts ',i,j,
8663 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8664 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8665 !     & 'gradcorr_long'
8666 ! Calculate the multi-body contribution to energy.
8667 !      ecorr=ecorr+ekont*ees
8668 ! Calculate multi-body contributions to the gradient.
8669       coeffpees0pij=coeffp*ees0pij
8670       coeffmees0mij=coeffm*ees0mij
8671       coeffpees0pkl=coeffp*ees0pkl
8672       coeffmees0mkl=coeffm*ees0mkl
8673       do ll=1,3
8674 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8675         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8676         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8677         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8678         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8679         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8680         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8681 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8682         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8683         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8684         coeffmees0mij*gacontm_hb1(ll,kk,k))
8685         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8686         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8687         coeffmees0mij*gacontm_hb2(ll,kk,k))
8688         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8689            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8690            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8691         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8692         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8693         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8694            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8695            coeffmees0mij*gacontm_hb3(ll,kk,k))
8696         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8697         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8698 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8699       enddo
8700 !      write (iout,*)
8701 !grad      do m=i+1,j-1
8702 !grad        do ll=1,3
8703 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8704 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8705 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8706 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8707 !grad        enddo
8708 !grad      enddo
8709 !grad      do m=k+1,l-1
8710 !grad        do ll=1,3
8711 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8712 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8713 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8714 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8715 !grad        enddo
8716 !grad      enddo
8717 !      write (iout,*) "ehbcorr",ekont*ees
8718       ehbcorr=ekont*ees
8719       if (shield_mode.gt.0) then
8720        j=ees0plist(jj,i)
8721        l=ees0plist(kk,k)
8722 !C        print *,i,j,fac_shield(i),fac_shield(j),
8723 !C     &fac_shield(k),fac_shield(l)
8724         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8725            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8726           do ilist=1,ishield_list(i)
8727            iresshield=shield_list(ilist,i)
8728            do m=1,3
8729            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8730            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8731                    rlocshield  &
8732             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8733             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8734             +rlocshield
8735            enddo
8736           enddo
8737           do ilist=1,ishield_list(j)
8738            iresshield=shield_list(ilist,j)
8739            do m=1,3
8740            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8741            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8742                    rlocshield &
8743             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8744            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8745             +rlocshield
8746            enddo
8747           enddo
8748
8749           do ilist=1,ishield_list(k)
8750            iresshield=shield_list(ilist,k)
8751            do m=1,3
8752            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8753            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8754                    rlocshield &
8755             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8756            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8757             +rlocshield
8758            enddo
8759           enddo
8760           do ilist=1,ishield_list(l)
8761            iresshield=shield_list(ilist,l)
8762            do m=1,3
8763            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8764            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8765                    rlocshield &
8766             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8767            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8768             +rlocshield
8769            enddo
8770           enddo
8771           do m=1,3
8772             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8773                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8774             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8775                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8776             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8777                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8778             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8779                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8780
8781             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8782                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8783             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8784                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8785             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8786                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8787             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8788                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8789
8790            enddo
8791       endif
8792       endif
8793       return
8794       end function ehbcorr
8795 #ifdef MOMENT
8796 !-----------------------------------------------------------------------------
8797       subroutine dipole(i,j,jj)
8798 !      implicit real*8 (a-h,o-z)
8799 !      include 'DIMENSIONS'
8800 !      include 'COMMON.IOUNITS'
8801 !      include 'COMMON.CHAIN'
8802 !      include 'COMMON.FFIELD'
8803 !      include 'COMMON.DERIV'
8804 !      include 'COMMON.INTERACT'
8805 !      include 'COMMON.CONTACTS'
8806 !      include 'COMMON.TORSION'
8807 !      include 'COMMON.VAR'
8808 !      include 'COMMON.GEO'
8809       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8810       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8811       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8812
8813       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8814       allocate(dipderx(3,5,4,maxconts,nres))
8815 !
8816
8817       iti1 = itortyp(itype(i+1,1))
8818       if (j.lt.nres-1) then
8819         itj1 = itype2loc(itype(j+1,1))
8820       else
8821         itj1=nloctyp
8822       endif
8823       do iii=1,2
8824         dipi(iii,1)=Ub2(iii,i)
8825         dipderi(iii)=Ub2der(iii,i)
8826         dipi(iii,2)=b1(iii,iti1)
8827         dipj(iii,1)=Ub2(iii,j)
8828         dipderj(iii)=Ub2der(iii,j)
8829         dipj(iii,2)=b1(iii,itj1)
8830       enddo
8831       kkk=0
8832       do iii=1,2
8833         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8834         do jjj=1,2
8835           kkk=kkk+1
8836           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8837         enddo
8838       enddo
8839       do kkk=1,5
8840         do lll=1,3
8841           mmm=0
8842           do iii=1,2
8843             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8844               auxvec(1))
8845             do jjj=1,2
8846               mmm=mmm+1
8847               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8848             enddo
8849           enddo
8850         enddo
8851       enddo
8852       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8853       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8854       do iii=1,2
8855         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8856       enddo
8857       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8858       do iii=1,2
8859         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8860       enddo
8861       return
8862       end subroutine dipole
8863 #endif
8864 !-----------------------------------------------------------------------------
8865       subroutine calc_eello(i,j,k,l,jj,kk)
8866 !
8867 ! This subroutine computes matrices and vectors needed to calculate
8868 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8869 !
8870       use comm_kut
8871 !      implicit real*8 (a-h,o-z)
8872 !      include 'DIMENSIONS'
8873 !      include 'COMMON.IOUNITS'
8874 !      include 'COMMON.CHAIN'
8875 !      include 'COMMON.DERIV'
8876 !      include 'COMMON.INTERACT'
8877 !      include 'COMMON.CONTACTS'
8878 !      include 'COMMON.TORSION'
8879 !      include 'COMMON.VAR'
8880 !      include 'COMMON.GEO'
8881 !      include 'COMMON.FFIELD'
8882       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8883       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8884       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8885               itj1
8886 !el      logical :: lprn
8887 !el      common /kutas/ lprn
8888 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8889 !d     & ' jj=',jj,' kk=',kk
8890 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8891 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8892 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8893       do iii=1,2
8894         do jjj=1,2
8895           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8896           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8897         enddo
8898       enddo
8899       call transpose2(aa1(1,1),aa1t(1,1))
8900       call transpose2(aa2(1,1),aa2t(1,1))
8901       do kkk=1,5
8902         do lll=1,3
8903           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8904             aa1tder(1,1,lll,kkk))
8905           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8906             aa2tder(1,1,lll,kkk))
8907         enddo
8908       enddo
8909       if (l.eq.j+1) then
8910 ! parallel orientation of the two CA-CA-CA frames.
8911         if (i.gt.1) then
8912           iti=itortyp(itype(i,1))
8913         else
8914           iti=ntortyp+1
8915         endif
8916         itk1=itortyp(itype(k+1,1))
8917         itj=itortyp(itype(j,1))
8918         if (l.lt.nres-1) then
8919           itl1=itortyp(itype(l+1,1))
8920         else
8921           itl1=ntortyp+1
8922         endif
8923 ! A1 kernel(j+1) A2T
8924 !d        do iii=1,2
8925 !d          write (iout,'(3f10.5,5x,3f10.5)')
8926 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8927 !d        enddo
8928         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8929          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8930          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8931 ! Following matrices are needed only for 6-th order cumulants
8932         IF (wcorr6.gt.0.0d0) THEN
8933         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8934          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8935          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8936         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8937          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8938          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8939          ADtEAderx(1,1,1,1,1,1))
8940         lprn=.false.
8941         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8942          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8943          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8944          ADtEA1derx(1,1,1,1,1,1))
8945         ENDIF
8946 ! End 6-th order cumulants
8947 !d        lprn=.false.
8948 !d        if (lprn) then
8949 !d        write (2,*) 'In calc_eello6'
8950 !d        do iii=1,2
8951 !d          write (2,*) 'iii=',iii
8952 !d          do kkk=1,5
8953 !d            write (2,*) 'kkk=',kkk
8954 !d            do jjj=1,2
8955 !d              write (2,'(3(2f10.5),5x)')
8956 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8957 !d            enddo
8958 !d          enddo
8959 !d        enddo
8960 !d        endif
8961         call transpose2(EUgder(1,1,k),auxmat(1,1))
8962         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8963         call transpose2(EUg(1,1,k),auxmat(1,1))
8964         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8965         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8966         do iii=1,2
8967           do kkk=1,5
8968             do lll=1,3
8969               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8970                 EAEAderx(1,1,lll,kkk,iii,1))
8971             enddo
8972           enddo
8973         enddo
8974 ! A1T kernel(i+1) A2
8975         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8976          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8977          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8978 ! Following matrices are needed only for 6-th order cumulants
8979         IF (wcorr6.gt.0.0d0) THEN
8980         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8981          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8982          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8983         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8984          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8985          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8986          ADtEAderx(1,1,1,1,1,2))
8987         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8988          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8989          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8990          ADtEA1derx(1,1,1,1,1,2))
8991         ENDIF
8992 ! End 6-th order cumulants
8993         call transpose2(EUgder(1,1,l),auxmat(1,1))
8994         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8995         call transpose2(EUg(1,1,l),auxmat(1,1))
8996         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8997         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8998         do iii=1,2
8999           do kkk=1,5
9000             do lll=1,3
9001               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9002                 EAEAderx(1,1,lll,kkk,iii,2))
9003             enddo
9004           enddo
9005         enddo
9006 ! AEAb1 and AEAb2
9007 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9008 ! They are needed only when the fifth- or the sixth-order cumulants are
9009 ! indluded.
9010         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9011         call transpose2(AEA(1,1,1),auxmat(1,1))
9012         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9013         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9014         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9015         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9016         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9017         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9018         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9019         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9020         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9021         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9022         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9023         call transpose2(AEA(1,1,2),auxmat(1,1))
9024         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9025         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9026         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9027         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9028         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9029         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9030         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9031         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9032         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9033         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9034         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9035 ! Calculate the Cartesian derivatives of the vectors.
9036         do iii=1,2
9037           do kkk=1,5
9038             do lll=1,3
9039               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9040               call matvec2(auxmat(1,1),b1(1,iti),&
9041                 AEAb1derx(1,lll,kkk,iii,1,1))
9042               call matvec2(auxmat(1,1),Ub2(1,i),&
9043                 AEAb2derx(1,lll,kkk,iii,1,1))
9044               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9045                 AEAb1derx(1,lll,kkk,iii,2,1))
9046               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9047                 AEAb2derx(1,lll,kkk,iii,2,1))
9048               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9049               call matvec2(auxmat(1,1),b1(1,itj),&
9050                 AEAb1derx(1,lll,kkk,iii,1,2))
9051               call matvec2(auxmat(1,1),Ub2(1,j),&
9052                 AEAb2derx(1,lll,kkk,iii,1,2))
9053               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9054                 AEAb1derx(1,lll,kkk,iii,2,2))
9055               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9056                 AEAb2derx(1,lll,kkk,iii,2,2))
9057             enddo
9058           enddo
9059         enddo
9060         ENDIF
9061 ! End vectors
9062       else
9063 ! Antiparallel orientation of the two CA-CA-CA frames.
9064         if (i.gt.1) then
9065           iti=itortyp(itype(i,1))
9066         else
9067           iti=ntortyp+1
9068         endif
9069         itk1=itortyp(itype(k+1,1))
9070         itl=itortyp(itype(l,1))
9071         itj=itortyp(itype(j,1))
9072         if (j.lt.nres-1) then
9073           itj1=itortyp(itype(j+1,1))
9074         else
9075           itj1=ntortyp+1
9076         endif
9077 ! A2 kernel(j-1)T A1T
9078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9079          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9080          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9081 ! Following matrices are needed only for 6-th order cumulants
9082         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9083            j.eq.i+4 .and. l.eq.i+3)) THEN
9084         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9085          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9086          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9087         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9088          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9089          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9090          ADtEAderx(1,1,1,1,1,1))
9091         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9092          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9093          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9094          ADtEA1derx(1,1,1,1,1,1))
9095         ENDIF
9096 ! End 6-th order cumulants
9097         call transpose2(EUgder(1,1,k),auxmat(1,1))
9098         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9099         call transpose2(EUg(1,1,k),auxmat(1,1))
9100         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9101         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9102         do iii=1,2
9103           do kkk=1,5
9104             do lll=1,3
9105               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9106                 EAEAderx(1,1,lll,kkk,iii,1))
9107             enddo
9108           enddo
9109         enddo
9110 ! A2T kernel(i+1)T A1
9111         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9112          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9113          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9114 ! Following matrices are needed only for 6-th order cumulants
9115         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9116            j.eq.i+4 .and. l.eq.i+3)) THEN
9117         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9118          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9119          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9120         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9121          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9122          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9123          ADtEAderx(1,1,1,1,1,2))
9124         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9125          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9126          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9127          ADtEA1derx(1,1,1,1,1,2))
9128         ENDIF
9129 ! End 6-th order cumulants
9130         call transpose2(EUgder(1,1,j),auxmat(1,1))
9131         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9132         call transpose2(EUg(1,1,j),auxmat(1,1))
9133         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9134         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9135         do iii=1,2
9136           do kkk=1,5
9137             do lll=1,3
9138               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9139                 EAEAderx(1,1,lll,kkk,iii,2))
9140             enddo
9141           enddo
9142         enddo
9143 ! AEAb1 and AEAb2
9144 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9145 ! They are needed only when the fifth- or the sixth-order cumulants are
9146 ! indluded.
9147         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9148           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9149         call transpose2(AEA(1,1,1),auxmat(1,1))
9150         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9151         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9152         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9153         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9154         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9155         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9156         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9157         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9158         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9159         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9160         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9161         call transpose2(AEA(1,1,2),auxmat(1,1))
9162         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9163         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9164         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9165         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9166         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9167         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9168         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9169         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9170         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9171         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9172         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9173 ! Calculate the Cartesian derivatives of the vectors.
9174         do iii=1,2
9175           do kkk=1,5
9176             do lll=1,3
9177               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9178               call matvec2(auxmat(1,1),b1(1,iti),&
9179                 AEAb1derx(1,lll,kkk,iii,1,1))
9180               call matvec2(auxmat(1,1),Ub2(1,i),&
9181                 AEAb2derx(1,lll,kkk,iii,1,1))
9182               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9183                 AEAb1derx(1,lll,kkk,iii,2,1))
9184               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9185                 AEAb2derx(1,lll,kkk,iii,2,1))
9186               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9187               call matvec2(auxmat(1,1),b1(1,itl),&
9188                 AEAb1derx(1,lll,kkk,iii,1,2))
9189               call matvec2(auxmat(1,1),Ub2(1,l),&
9190                 AEAb2derx(1,lll,kkk,iii,1,2))
9191               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9192                 AEAb1derx(1,lll,kkk,iii,2,2))
9193               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9194                 AEAb2derx(1,lll,kkk,iii,2,2))
9195             enddo
9196           enddo
9197         enddo
9198         ENDIF
9199 ! End vectors
9200       endif
9201       return
9202       end subroutine calc_eello
9203 !-----------------------------------------------------------------------------
9204       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9205       use comm_kut
9206       implicit none
9207       integer :: nderg
9208       logical :: transp
9209       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9210       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9211       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9212       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9213       integer :: iii,kkk,lll
9214       integer :: jjj,mmm
9215 !el      logical :: lprn
9216 !el      common /kutas/ lprn
9217       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9218       do iii=1,nderg
9219         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9220           AKAderg(1,1,iii))
9221       enddo
9222 !d      if (lprn) write (2,*) 'In kernel'
9223       do kkk=1,5
9224 !d        if (lprn) write (2,*) 'kkk=',kkk
9225         do lll=1,3
9226           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9227             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9228 !d          if (lprn) then
9229 !d            write (2,*) 'lll=',lll
9230 !d            write (2,*) 'iii=1'
9231 !d            do jjj=1,2
9232 !d              write (2,'(3(2f10.5),5x)')
9233 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9234 !d            enddo
9235 !d          endif
9236           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9237             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9238 !d          if (lprn) then
9239 !d            write (2,*) 'lll=',lll
9240 !d            write (2,*) 'iii=2'
9241 !d            do jjj=1,2
9242 !d              write (2,'(3(2f10.5),5x)')
9243 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9244 !d            enddo
9245 !d          endif
9246         enddo
9247       enddo
9248       return
9249       end subroutine kernel
9250 !-----------------------------------------------------------------------------
9251       real(kind=8) function eello4(i,j,k,l,jj,kk)
9252 !      implicit real*8 (a-h,o-z)
9253 !      include 'DIMENSIONS'
9254 !      include 'COMMON.IOUNITS'
9255 !      include 'COMMON.CHAIN'
9256 !      include 'COMMON.DERIV'
9257 !      include 'COMMON.INTERACT'
9258 !      include 'COMMON.CONTACTS'
9259 !      include 'COMMON.TORSION'
9260 !      include 'COMMON.VAR'
9261 !      include 'COMMON.GEO'
9262       real(kind=8),dimension(2,2) :: pizda
9263       real(kind=8),dimension(3) :: ggg1,ggg2
9264       real(kind=8) ::  eel4,glongij,glongkl
9265       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9266 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9267 !d        eello4=0.0d0
9268 !d        return
9269 !d      endif
9270 !d      print *,'eello4:',i,j,k,l,jj,kk
9271 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9272 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9273 !old      eij=facont_hb(jj,i)
9274 !old      ekl=facont_hb(kk,k)
9275 !old      ekont=eij*ekl
9276       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9277 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9278       gcorr_loc(k-1)=gcorr_loc(k-1) &
9279          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9280       if (l.eq.j+1) then
9281         gcorr_loc(l-1)=gcorr_loc(l-1) &
9282            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9283       else
9284         gcorr_loc(j-1)=gcorr_loc(j-1) &
9285            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9286       endif
9287       do iii=1,2
9288         do kkk=1,5
9289           do lll=1,3
9290             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9291                               -EAEAderx(2,2,lll,kkk,iii,1)
9292 !d            derx(lll,kkk,iii)=0.0d0
9293           enddo
9294         enddo
9295       enddo
9296 !d      gcorr_loc(l-1)=0.0d0
9297 !d      gcorr_loc(j-1)=0.0d0
9298 !d      gcorr_loc(k-1)=0.0d0
9299 !d      eel4=1.0d0
9300 !d      write (iout,*)'Contacts have occurred for peptide groups',
9301 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9302 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9303       if (j.lt.nres-1) then
9304         j1=j+1
9305         j2=j-1
9306       else
9307         j1=j-1
9308         j2=j-2
9309       endif
9310       if (l.lt.nres-1) then
9311         l1=l+1
9312         l2=l-1
9313       else
9314         l1=l-1
9315         l2=l-2
9316       endif
9317       do ll=1,3
9318 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9319 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9320         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9321         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9322 !grad        ghalf=0.5d0*ggg1(ll)
9323         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9324         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9325         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9326         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9327         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9328         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9329 !grad        ghalf=0.5d0*ggg2(ll)
9330         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9331         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9332         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9333         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9334         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9335         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9336       enddo
9337 !grad      do m=i+1,j-1
9338 !grad        do ll=1,3
9339 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9340 !grad        enddo
9341 !grad      enddo
9342 !grad      do m=k+1,l-1
9343 !grad        do ll=1,3
9344 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9345 !grad        enddo
9346 !grad      enddo
9347 !grad      do m=i+2,j2
9348 !grad        do ll=1,3
9349 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9350 !grad        enddo
9351 !grad      enddo
9352 !grad      do m=k+2,l2
9353 !grad        do ll=1,3
9354 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9355 !grad        enddo
9356 !grad      enddo
9357 !d      do iii=1,nres-3
9358 !d        write (2,*) iii,gcorr_loc(iii)
9359 !d      enddo
9360       eello4=ekont*eel4
9361 !d      write (2,*) 'ekont',ekont
9362 !d      write (iout,*) 'eello4',ekont*eel4
9363       return
9364       end function eello4
9365 !-----------------------------------------------------------------------------
9366       real(kind=8) function eello5(i,j,k,l,jj,kk)
9367 !      implicit real*8 (a-h,o-z)
9368 !      include 'DIMENSIONS'
9369 !      include 'COMMON.IOUNITS'
9370 !      include 'COMMON.CHAIN'
9371 !      include 'COMMON.DERIV'
9372 !      include 'COMMON.INTERACT'
9373 !      include 'COMMON.CONTACTS'
9374 !      include 'COMMON.TORSION'
9375 !      include 'COMMON.VAR'
9376 !      include 'COMMON.GEO'
9377       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9378       real(kind=8),dimension(2) :: vv
9379       real(kind=8),dimension(3) :: ggg1,ggg2
9380       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9381       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9382       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9383 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9384 !                                                                              C
9385 !                            Parallel chains                                   C
9386 !                                                                              C
9387 !          o             o                   o             o                   C
9388 !         /l\           / \             \   / \           / \   /              C
9389 !        /   \         /   \             \ /   \         /   \ /               C
9390 !       j| o |l1       | o |                o| o |         | o |o                C
9391 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9392 !      \i/   \         /   \ /             /   \         /   \                 C
9393 !       o    k1             o                                                  C
9394 !         (I)          (II)                (III)          (IV)                 C
9395 !                                                                              C
9396 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9397 !                                                                              C
9398 !                            Antiparallel chains                               C
9399 !                                                                              C
9400 !          o             o                   o             o                   C
9401 !         /j\           / \             \   / \           / \   /              C
9402 !        /   \         /   \             \ /   \         /   \ /               C
9403 !      j1| o |l        | o |                o| o |         | o |o                C
9404 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9405 !      \i/   \         /   \ /             /   \         /   \                 C
9406 !       o     k1            o                                                  C
9407 !         (I)          (II)                (III)          (IV)                 C
9408 !                                                                              C
9409 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9410 !                                                                              C
9411 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9412 !                                                                              C
9413 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9414 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9415 !d        eello5=0.0d0
9416 !d        return
9417 !d      endif
9418 !d      write (iout,*)
9419 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9420 !d     &   ' and',k,l
9421       itk=itortyp(itype(k,1))
9422       itl=itortyp(itype(l,1))
9423       itj=itortyp(itype(j,1))
9424       eello5_1=0.0d0
9425       eello5_2=0.0d0
9426       eello5_3=0.0d0
9427       eello5_4=0.0d0
9428 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9429 !d     &   eel5_3_num,eel5_4_num)
9430       do iii=1,2
9431         do kkk=1,5
9432           do lll=1,3
9433             derx(lll,kkk,iii)=0.0d0
9434           enddo
9435         enddo
9436       enddo
9437 !d      eij=facont_hb(jj,i)
9438 !d      ekl=facont_hb(kk,k)
9439 !d      ekont=eij*ekl
9440 !d      write (iout,*)'Contacts have occurred for peptide groups',
9441 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9442 !d      goto 1111
9443 ! Contribution from the graph I.
9444 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9445 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9446       call transpose2(EUg(1,1,k),auxmat(1,1))
9447       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9448       vv(1)=pizda(1,1)-pizda(2,2)
9449       vv(2)=pizda(1,2)+pizda(2,1)
9450       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9451        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9452 ! Explicit gradient in virtual-dihedral angles.
9453       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9454        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9455        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9456       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9457       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9458       vv(1)=pizda(1,1)-pizda(2,2)
9459       vv(2)=pizda(1,2)+pizda(2,1)
9460       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9461        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9462        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9463       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9464       vv(1)=pizda(1,1)-pizda(2,2)
9465       vv(2)=pizda(1,2)+pizda(2,1)
9466       if (l.eq.j+1) then
9467         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9468          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9469          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9470       else
9471         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9472          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9473          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9474       endif
9475 ! Cartesian gradient
9476       do iii=1,2
9477         do kkk=1,5
9478           do lll=1,3
9479             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9480               pizda(1,1))
9481             vv(1)=pizda(1,1)-pizda(2,2)
9482             vv(2)=pizda(1,2)+pizda(2,1)
9483             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9484              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9485              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9486           enddo
9487         enddo
9488       enddo
9489 !      goto 1112
9490 !1111  continue
9491 ! Contribution from graph II
9492       call transpose2(EE(1,1,itk),auxmat(1,1))
9493       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9494       vv(1)=pizda(1,1)+pizda(2,2)
9495       vv(2)=pizda(2,1)-pizda(1,2)
9496       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9497        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9498 ! Explicit gradient in virtual-dihedral angles.
9499       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9500        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9501       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9502       vv(1)=pizda(1,1)+pizda(2,2)
9503       vv(2)=pizda(2,1)-pizda(1,2)
9504       if (l.eq.j+1) then
9505         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9506          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9507          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9508       else
9509         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9510          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9511          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9512       endif
9513 ! Cartesian gradient
9514       do iii=1,2
9515         do kkk=1,5
9516           do lll=1,3
9517             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9518               pizda(1,1))
9519             vv(1)=pizda(1,1)+pizda(2,2)
9520             vv(2)=pizda(2,1)-pizda(1,2)
9521             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9522              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9523              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9524           enddo
9525         enddo
9526       enddo
9527 !d      goto 1112
9528 !d1111  continue
9529       if (l.eq.j+1) then
9530 !d        goto 1110
9531 ! Parallel orientation
9532 ! Contribution from graph III
9533         call transpose2(EUg(1,1,l),auxmat(1,1))
9534         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9535         vv(1)=pizda(1,1)-pizda(2,2)
9536         vv(2)=pizda(1,2)+pizda(2,1)
9537         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9538          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9539 ! Explicit gradient in virtual-dihedral angles.
9540         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9541          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9542          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9543         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9544         vv(1)=pizda(1,1)-pizda(2,2)
9545         vv(2)=pizda(1,2)+pizda(2,1)
9546         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9547          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9548          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9549         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9550         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9551         vv(1)=pizda(1,1)-pizda(2,2)
9552         vv(2)=pizda(1,2)+pizda(2,1)
9553         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9554          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9555          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9556 ! Cartesian gradient
9557         do iii=1,2
9558           do kkk=1,5
9559             do lll=1,3
9560               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9561                 pizda(1,1))
9562               vv(1)=pizda(1,1)-pizda(2,2)
9563               vv(2)=pizda(1,2)+pizda(2,1)
9564               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9565                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9566                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9567             enddo
9568           enddo
9569         enddo
9570 !d        goto 1112
9571 ! Contribution from graph IV
9572 !d1110    continue
9573         call transpose2(EE(1,1,itl),auxmat(1,1))
9574         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9575         vv(1)=pizda(1,1)+pizda(2,2)
9576         vv(2)=pizda(2,1)-pizda(1,2)
9577         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9578          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9579 ! Explicit gradient in virtual-dihedral angles.
9580         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9581          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9582         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9583         vv(1)=pizda(1,1)+pizda(2,2)
9584         vv(2)=pizda(2,1)-pizda(1,2)
9585         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9586          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9587          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9588 ! Cartesian gradient
9589         do iii=1,2
9590           do kkk=1,5
9591             do lll=1,3
9592               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9593                 pizda(1,1))
9594               vv(1)=pizda(1,1)+pizda(2,2)
9595               vv(2)=pizda(2,1)-pizda(1,2)
9596               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9597                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9598                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9599             enddo
9600           enddo
9601         enddo
9602       else
9603 ! Antiparallel orientation
9604 ! Contribution from graph III
9605 !        goto 1110
9606         call transpose2(EUg(1,1,j),auxmat(1,1))
9607         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9608         vv(1)=pizda(1,1)-pizda(2,2)
9609         vv(2)=pizda(1,2)+pizda(2,1)
9610         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9611          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9612 ! Explicit gradient in virtual-dihedral angles.
9613         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9614          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9615          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9616         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9617         vv(1)=pizda(1,1)-pizda(2,2)
9618         vv(2)=pizda(1,2)+pizda(2,1)
9619         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9620          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9621          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9622         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9623         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9624         vv(1)=pizda(1,1)-pizda(2,2)
9625         vv(2)=pizda(1,2)+pizda(2,1)
9626         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9627          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9628          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9629 ! Cartesian gradient
9630         do iii=1,2
9631           do kkk=1,5
9632             do lll=1,3
9633               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9634                 pizda(1,1))
9635               vv(1)=pizda(1,1)-pizda(2,2)
9636               vv(2)=pizda(1,2)+pizda(2,1)
9637               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9638                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9639                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9640             enddo
9641           enddo
9642         enddo
9643 !d        goto 1112
9644 ! Contribution from graph IV
9645 1110    continue
9646         call transpose2(EE(1,1,itj),auxmat(1,1))
9647         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9648         vv(1)=pizda(1,1)+pizda(2,2)
9649         vv(2)=pizda(2,1)-pizda(1,2)
9650         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9651          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9652 ! Explicit gradient in virtual-dihedral angles.
9653         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9654          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9655         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9656         vv(1)=pizda(1,1)+pizda(2,2)
9657         vv(2)=pizda(2,1)-pizda(1,2)
9658         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9659          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9660          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9661 ! Cartesian gradient
9662         do iii=1,2
9663           do kkk=1,5
9664             do lll=1,3
9665               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9666                 pizda(1,1))
9667               vv(1)=pizda(1,1)+pizda(2,2)
9668               vv(2)=pizda(2,1)-pizda(1,2)
9669               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9670                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9671                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9672             enddo
9673           enddo
9674         enddo
9675       endif
9676 1112  continue
9677       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9678 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9679 !d        write (2,*) 'ijkl',i,j,k,l
9680 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9681 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9682 !d      endif
9683 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9684 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9685 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9686 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9687       if (j.lt.nres-1) then
9688         j1=j+1
9689         j2=j-1
9690       else
9691         j1=j-1
9692         j2=j-2
9693       endif
9694       if (l.lt.nres-1) then
9695         l1=l+1
9696         l2=l-1
9697       else
9698         l1=l-1
9699         l2=l-2
9700       endif
9701 !d      eij=1.0d0
9702 !d      ekl=1.0d0
9703 !d      ekont=1.0d0
9704 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9705 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9706 !        summed up outside the subrouine as for the other subroutines
9707 !        handling long-range interactions. The old code is commented out
9708 !        with "cgrad" to keep track of changes.
9709       do ll=1,3
9710 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9711 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9712         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9713         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9714 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9715 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9716 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9717 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9718 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9719 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9720 !     &   gradcorr5ij,
9721 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9722 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9723 !grad        ghalf=0.5d0*ggg1(ll)
9724 !d        ghalf=0.0d0
9725         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9726         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9727         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9728         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9729         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9730         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9731 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9732 !grad        ghalf=0.5d0*ggg2(ll)
9733         ghalf=0.0d0
9734         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9735         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9736         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9737         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9738         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9739         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9740       enddo
9741 !d      goto 1112
9742 !grad      do m=i+1,j-1
9743 !grad        do ll=1,3
9744 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9745 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9746 !grad        enddo
9747 !grad      enddo
9748 !grad      do m=k+1,l-1
9749 !grad        do ll=1,3
9750 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9751 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9752 !grad        enddo
9753 !grad      enddo
9754 !1112  continue
9755 !grad      do m=i+2,j2
9756 !grad        do ll=1,3
9757 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9758 !grad        enddo
9759 !grad      enddo
9760 !grad      do m=k+2,l2
9761 !grad        do ll=1,3
9762 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9763 !grad        enddo
9764 !grad      enddo
9765 !d      do iii=1,nres-3
9766 !d        write (2,*) iii,g_corr5_loc(iii)
9767 !d      enddo
9768       eello5=ekont*eel5
9769 !d      write (2,*) 'ekont',ekont
9770 !d      write (iout,*) 'eello5',ekont*eel5
9771       return
9772       end function eello5
9773 !-----------------------------------------------------------------------------
9774       real(kind=8) function eello6(i,j,k,l,jj,kk)
9775 !      implicit real*8 (a-h,o-z)
9776 !      include 'DIMENSIONS'
9777 !      include 'COMMON.IOUNITS'
9778 !      include 'COMMON.CHAIN'
9779 !      include 'COMMON.DERIV'
9780 !      include 'COMMON.INTERACT'
9781 !      include 'COMMON.CONTACTS'
9782 !      include 'COMMON.TORSION'
9783 !      include 'COMMON.VAR'
9784 !      include 'COMMON.GEO'
9785 !      include 'COMMON.FFIELD'
9786       real(kind=8),dimension(3) :: ggg1,ggg2
9787       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9788                    eello6_6,eel6
9789       real(kind=8) :: gradcorr6ij,gradcorr6kl
9790       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9791 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9792 !d        eello6=0.0d0
9793 !d        return
9794 !d      endif
9795 !d      write (iout,*)
9796 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9797 !d     &   ' and',k,l
9798       eello6_1=0.0d0
9799       eello6_2=0.0d0
9800       eello6_3=0.0d0
9801       eello6_4=0.0d0
9802       eello6_5=0.0d0
9803       eello6_6=0.0d0
9804 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9805 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9806       do iii=1,2
9807         do kkk=1,5
9808           do lll=1,3
9809             derx(lll,kkk,iii)=0.0d0
9810           enddo
9811         enddo
9812       enddo
9813 !d      eij=facont_hb(jj,i)
9814 !d      ekl=facont_hb(kk,k)
9815 !d      ekont=eij*ekl
9816 !d      eij=1.0d0
9817 !d      ekl=1.0d0
9818 !d      ekont=1.0d0
9819       if (l.eq.j+1) then
9820         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9821         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9822         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9823         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9824         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9825         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9826       else
9827         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9828         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9829         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9830         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9831         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9832           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9833         else
9834           eello6_5=0.0d0
9835         endif
9836         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9837       endif
9838 ! If turn contributions are considered, they will be handled separately.
9839       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9840 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9841 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9842 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9843 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9844 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9845 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9846 !d      goto 1112
9847       if (j.lt.nres-1) then
9848         j1=j+1
9849         j2=j-1
9850       else
9851         j1=j-1
9852         j2=j-2
9853       endif
9854       if (l.lt.nres-1) then
9855         l1=l+1
9856         l2=l-1
9857       else
9858         l1=l-1
9859         l2=l-2
9860       endif
9861       do ll=1,3
9862 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9863 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9864 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9865 !grad        ghalf=0.5d0*ggg1(ll)
9866 !d        ghalf=0.0d0
9867         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9868         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9869         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9870         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9871         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9872         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9873         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9874         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9875 !grad        ghalf=0.5d0*ggg2(ll)
9876 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9877 !d        ghalf=0.0d0
9878         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9879         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9880         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9881         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9882         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9883         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9884       enddo
9885 !d      goto 1112
9886 !grad      do m=i+1,j-1
9887 !grad        do ll=1,3
9888 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9889 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9890 !grad        enddo
9891 !grad      enddo
9892 !grad      do m=k+1,l-1
9893 !grad        do ll=1,3
9894 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9895 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9896 !grad        enddo
9897 !grad      enddo
9898 !grad1112  continue
9899 !grad      do m=i+2,j2
9900 !grad        do ll=1,3
9901 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9902 !grad        enddo
9903 !grad      enddo
9904 !grad      do m=k+2,l2
9905 !grad        do ll=1,3
9906 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9907 !grad        enddo
9908 !grad      enddo
9909 !d      do iii=1,nres-3
9910 !d        write (2,*) iii,g_corr6_loc(iii)
9911 !d      enddo
9912       eello6=ekont*eel6
9913 !d      write (2,*) 'ekont',ekont
9914 !d      write (iout,*) 'eello6',ekont*eel6
9915       return
9916       end function eello6
9917 !-----------------------------------------------------------------------------
9918       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9919       use comm_kut
9920 !      implicit real*8 (a-h,o-z)
9921 !      include 'DIMENSIONS'
9922 !      include 'COMMON.IOUNITS'
9923 !      include 'COMMON.CHAIN'
9924 !      include 'COMMON.DERIV'
9925 !      include 'COMMON.INTERACT'
9926 !      include 'COMMON.CONTACTS'
9927 !      include 'COMMON.TORSION'
9928 !      include 'COMMON.VAR'
9929 !      include 'COMMON.GEO'
9930       real(kind=8),dimension(2) :: vv,vv1
9931       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9932       logical :: swap
9933 !el      logical :: lprn
9934 !el      common /kutas/ lprn
9935       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9936       real(kind=8) :: s1,s2,s3,s4,s5
9937 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9938 !                                                                              C
9939 !      Parallel       Antiparallel                                             C
9940 !                                                                              C
9941 !          o             o                                                     C
9942 !         /l\           /j\                                                    C
9943 !        /   \         /   \                                                   C
9944 !       /| o |         | o |\                                                  C
9945 !     \ j|/k\|  /   \  |/k\|l /                                                C
9946 !      \ /   \ /     \ /   \ /                                                 C
9947 !       o     o       o     o                                                  C
9948 !       i             i                                                        C
9949 !                                                                              C
9950 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9951       itk=itortyp(itype(k,1))
9952       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9953       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9954       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9955       call transpose2(EUgC(1,1,k),auxmat(1,1))
9956       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9957       vv1(1)=pizda1(1,1)-pizda1(2,2)
9958       vv1(2)=pizda1(1,2)+pizda1(2,1)
9959       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9960       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9961       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9962       s5=scalar2(vv(1),Dtobr2(1,i))
9963 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9964       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9965       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9966        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9967        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9968        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9969        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9970        +scalar2(vv(1),Dtobr2der(1,i)))
9971       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9972       vv1(1)=pizda1(1,1)-pizda1(2,2)
9973       vv1(2)=pizda1(1,2)+pizda1(2,1)
9974       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9975       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9976       if (l.eq.j+1) then
9977         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9978        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9979        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9980        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9981        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9982       else
9983         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9984        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9985        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9986        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9987        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9988       endif
9989       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9990       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9991       vv1(1)=pizda1(1,1)-pizda1(2,2)
9992       vv1(2)=pizda1(1,2)+pizda1(2,1)
9993       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9994        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9995        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9996        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9997       do iii=1,2
9998         if (swap) then
9999           ind=3-iii
10000         else
10001           ind=iii
10002         endif
10003         do kkk=1,5
10004           do lll=1,3
10005             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10006             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10007             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10008             call transpose2(EUgC(1,1,k),auxmat(1,1))
10009             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10010               pizda1(1,1))
10011             vv1(1)=pizda1(1,1)-pizda1(2,2)
10012             vv1(2)=pizda1(1,2)+pizda1(2,1)
10013             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10014             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10015              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10016             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10017              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10018             s5=scalar2(vv(1),Dtobr2(1,i))
10019             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10020           enddo
10021         enddo
10022       enddo
10023       return
10024       end function eello6_graph1
10025 !-----------------------------------------------------------------------------
10026       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10027       use comm_kut
10028 !      implicit real*8 (a-h,o-z)
10029 !      include 'DIMENSIONS'
10030 !      include 'COMMON.IOUNITS'
10031 !      include 'COMMON.CHAIN'
10032 !      include 'COMMON.DERIV'
10033 !      include 'COMMON.INTERACT'
10034 !      include 'COMMON.CONTACTS'
10035 !      include 'COMMON.TORSION'
10036 !      include 'COMMON.VAR'
10037 !      include 'COMMON.GEO'
10038       logical :: swap
10039       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10040       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10041 !el      logical :: lprn
10042 !el      common /kutas/ lprn
10043       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10044       real(kind=8) :: s2,s3,s4
10045 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10046 !                                                                              C
10047 !      Parallel       Antiparallel                                             C
10048 !                                                                              C
10049 !          o             o                                                     C
10050 !     \   /l\           /j\   /                                                C
10051 !      \ /   \         /   \ /                                                 C
10052 !       o| o |         | o |o                                                  C
10053 !     \ j|/k\|      \  |/k\|l                                                  C
10054 !      \ /   \       \ /   \                                                   C
10055 !       o             o                                                        C
10056 !       i             i                                                        C
10057 !                                                                              C
10058 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10059 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10060 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10061 !           but not in a cluster cumulant
10062 #ifdef MOMENT
10063       s1=dip(1,jj,i)*dip(1,kk,k)
10064 #endif
10065       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10066       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10067       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10068       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10069       call transpose2(EUg(1,1,k),auxmat(1,1))
10070       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10071       vv(1)=pizda(1,1)-pizda(2,2)
10072       vv(2)=pizda(1,2)+pizda(2,1)
10073       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10074 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10075 #ifdef MOMENT
10076       eello6_graph2=-(s1+s2+s3+s4)
10077 #else
10078       eello6_graph2=-(s2+s3+s4)
10079 #endif
10080 !      eello6_graph2=-s3
10081 ! Derivatives in gamma(i-1)
10082       if (i.gt.1) then
10083 #ifdef MOMENT
10084         s1=dipderg(1,jj,i)*dip(1,kk,k)
10085 #endif
10086         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10087         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10088         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10089         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10090 #ifdef MOMENT
10091         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10092 #else
10093         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10094 #endif
10095 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10096       endif
10097 ! Derivatives in gamma(k-1)
10098 #ifdef MOMENT
10099       s1=dip(1,jj,i)*dipderg(1,kk,k)
10100 #endif
10101       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10102       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10103       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10104       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10105       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10106       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10107       vv(1)=pizda(1,1)-pizda(2,2)
10108       vv(2)=pizda(1,2)+pizda(2,1)
10109       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10110 #ifdef MOMENT
10111       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10112 #else
10113       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10114 #endif
10115 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10116 ! Derivatives in gamma(j-1) or gamma(l-1)
10117       if (j.gt.1) then
10118 #ifdef MOMENT
10119         s1=dipderg(3,jj,i)*dip(1,kk,k)
10120 #endif
10121         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10122         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10123         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10124         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10125         vv(1)=pizda(1,1)-pizda(2,2)
10126         vv(2)=pizda(1,2)+pizda(2,1)
10127         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10128 #ifdef MOMENT
10129         if (swap) then
10130           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10131         else
10132           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10133         endif
10134 #endif
10135         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10136 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10137       endif
10138 ! Derivatives in gamma(l-1) or gamma(j-1)
10139       if (l.gt.1) then
10140 #ifdef MOMENT
10141         s1=dip(1,jj,i)*dipderg(3,kk,k)
10142 #endif
10143         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10144         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10145         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10146         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10147         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10148         vv(1)=pizda(1,1)-pizda(2,2)
10149         vv(2)=pizda(1,2)+pizda(2,1)
10150         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10151 #ifdef MOMENT
10152         if (swap) then
10153           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10154         else
10155           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10156         endif
10157 #endif
10158         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10159 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10160       endif
10161 ! Cartesian derivatives.
10162       if (lprn) then
10163         write (2,*) 'In eello6_graph2'
10164         do iii=1,2
10165           write (2,*) 'iii=',iii
10166           do kkk=1,5
10167             write (2,*) 'kkk=',kkk
10168             do jjj=1,2
10169               write (2,'(3(2f10.5),5x)') &
10170               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10171             enddo
10172           enddo
10173         enddo
10174       endif
10175       do iii=1,2
10176         do kkk=1,5
10177           do lll=1,3
10178 #ifdef MOMENT
10179             if (iii.eq.1) then
10180               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10181             else
10182               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10183             endif
10184 #endif
10185             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10186               auxvec(1))
10187             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10188             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10189               auxvec(1))
10190             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10191             call transpose2(EUg(1,1,k),auxmat(1,1))
10192             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10193               pizda(1,1))
10194             vv(1)=pizda(1,1)-pizda(2,2)
10195             vv(2)=pizda(1,2)+pizda(2,1)
10196             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10197 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10198 #ifdef MOMENT
10199             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10200 #else
10201             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10202 #endif
10203             if (swap) then
10204               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10205             else
10206               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10207             endif
10208           enddo
10209         enddo
10210       enddo
10211       return
10212       end function eello6_graph2
10213 !-----------------------------------------------------------------------------
10214       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10215 !      implicit real*8 (a-h,o-z)
10216 !      include 'DIMENSIONS'
10217 !      include 'COMMON.IOUNITS'
10218 !      include 'COMMON.CHAIN'
10219 !      include 'COMMON.DERIV'
10220 !      include 'COMMON.INTERACT'
10221 !      include 'COMMON.CONTACTS'
10222 !      include 'COMMON.TORSION'
10223 !      include 'COMMON.VAR'
10224 !      include 'COMMON.GEO'
10225       real(kind=8),dimension(2) :: vv,auxvec
10226       real(kind=8),dimension(2,2) :: pizda,auxmat
10227       logical :: swap
10228       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10229       real(kind=8) :: s1,s2,s3,s4
10230 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10231 !                                                                              C
10232 !      Parallel       Antiparallel                                             C
10233 !                                                                              C
10234 !          o             o                                                     C
10235 !         /l\   /   \   /j\                                                    C
10236 !        /   \ /     \ /   \                                                   C
10237 !       /| o |o       o| o |\                                                  C
10238 !       j|/k\|  /      |/k\|l /                                                C
10239 !        /   \ /       /   \ /                                                 C
10240 !       /     o       /     o                                                  C
10241 !       i             i                                                        C
10242 !                                                                              C
10243 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10244 !
10245 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10246 !           energy moment and not to the cluster cumulant.
10247       iti=itortyp(itype(i,1))
10248       if (j.lt.nres-1) then
10249         itj1=itortyp(itype(j+1,1))
10250       else
10251         itj1=ntortyp+1
10252       endif
10253       itk=itortyp(itype(k,1))
10254       itk1=itortyp(itype(k+1,1))
10255       if (l.lt.nres-1) then
10256         itl1=itortyp(itype(l+1,1))
10257       else
10258         itl1=ntortyp+1
10259       endif
10260 #ifdef MOMENT
10261       s1=dip(4,jj,i)*dip(4,kk,k)
10262 #endif
10263       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10264       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10265       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10266       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10267       call transpose2(EE(1,1,itk),auxmat(1,1))
10268       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10269       vv(1)=pizda(1,1)+pizda(2,2)
10270       vv(2)=pizda(2,1)-pizda(1,2)
10271       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10272 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10273 !d     & "sum",-(s2+s3+s4)
10274 #ifdef MOMENT
10275       eello6_graph3=-(s1+s2+s3+s4)
10276 #else
10277       eello6_graph3=-(s2+s3+s4)
10278 #endif
10279 !      eello6_graph3=-s4
10280 ! Derivatives in gamma(k-1)
10281       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10282       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10283       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10284       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10285 ! Derivatives in gamma(l-1)
10286       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10287       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10288       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10289       vv(1)=pizda(1,1)+pizda(2,2)
10290       vv(2)=pizda(2,1)-pizda(1,2)
10291       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10292       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10293 ! Cartesian derivatives.
10294       do iii=1,2
10295         do kkk=1,5
10296           do lll=1,3
10297 #ifdef MOMENT
10298             if (iii.eq.1) then
10299               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10300             else
10301               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10302             endif
10303 #endif
10304             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10305               auxvec(1))
10306             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10307             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10308               auxvec(1))
10309             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10310             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10311               pizda(1,1))
10312             vv(1)=pizda(1,1)+pizda(2,2)
10313             vv(2)=pizda(2,1)-pizda(1,2)
10314             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10315 #ifdef MOMENT
10316             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10317 #else
10318             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10319 #endif
10320             if (swap) then
10321               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10322             else
10323               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10324             endif
10325 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10326           enddo
10327         enddo
10328       enddo
10329       return
10330       end function eello6_graph3
10331 !-----------------------------------------------------------------------------
10332       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10333 !      implicit real*8 (a-h,o-z)
10334 !      include 'DIMENSIONS'
10335 !      include 'COMMON.IOUNITS'
10336 !      include 'COMMON.CHAIN'
10337 !      include 'COMMON.DERIV'
10338 !      include 'COMMON.INTERACT'
10339 !      include 'COMMON.CONTACTS'
10340 !      include 'COMMON.TORSION'
10341 !      include 'COMMON.VAR'
10342 !      include 'COMMON.GEO'
10343 !      include 'COMMON.FFIELD'
10344       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10345       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10346       logical :: swap
10347       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10348               iii,kkk,lll
10349       real(kind=8) :: s1,s2,s3,s4
10350 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10351 !                                                                              C
10352 !      Parallel       Antiparallel                                             C
10353 !                                                                              C
10354 !          o             o                                                     C
10355 !         /l\   /   \   /j\                                                    C
10356 !        /   \ /     \ /   \                                                   C
10357 !       /| o |o       o| o |\                                                  C
10358 !     \ j|/k\|      \  |/k\|l                                                  C
10359 !      \ /   \       \ /   \                                                   C
10360 !       o     \       o     \                                                  C
10361 !       i             i                                                        C
10362 !                                                                              C
10363 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10364 !
10365 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10366 !           energy moment and not to the cluster cumulant.
10367 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10368       iti=itortyp(itype(i,1))
10369       itj=itortyp(itype(j,1))
10370       if (j.lt.nres-1) then
10371         itj1=itortyp(itype(j+1,1))
10372       else
10373         itj1=ntortyp+1
10374       endif
10375       itk=itortyp(itype(k,1))
10376       if (k.lt.nres-1) then
10377         itk1=itortyp(itype(k+1,1))
10378       else
10379         itk1=ntortyp+1
10380       endif
10381       itl=itortyp(itype(l,1))
10382       if (l.lt.nres-1) then
10383         itl1=itortyp(itype(l+1,1))
10384       else
10385         itl1=ntortyp+1
10386       endif
10387 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10388 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10389 !d     & ' itl',itl,' itl1',itl1
10390 #ifdef MOMENT
10391       if (imat.eq.1) then
10392         s1=dip(3,jj,i)*dip(3,kk,k)
10393       else
10394         s1=dip(2,jj,j)*dip(2,kk,l)
10395       endif
10396 #endif
10397       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10398       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10399       if (j.eq.l+1) then
10400         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10401         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10402       else
10403         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10404         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10405       endif
10406       call transpose2(EUg(1,1,k),auxmat(1,1))
10407       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10408       vv(1)=pizda(1,1)-pizda(2,2)
10409       vv(2)=pizda(2,1)+pizda(1,2)
10410       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10411 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10412 #ifdef MOMENT
10413       eello6_graph4=-(s1+s2+s3+s4)
10414 #else
10415       eello6_graph4=-(s2+s3+s4)
10416 #endif
10417 ! Derivatives in gamma(i-1)
10418       if (i.gt.1) then
10419 #ifdef MOMENT
10420         if (imat.eq.1) then
10421           s1=dipderg(2,jj,i)*dip(3,kk,k)
10422         else
10423           s1=dipderg(4,jj,j)*dip(2,kk,l)
10424         endif
10425 #endif
10426         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10427         if (j.eq.l+1) then
10428           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10429           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10430         else
10431           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10432           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10433         endif
10434         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10435         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10436 !d          write (2,*) 'turn6 derivatives'
10437 #ifdef MOMENT
10438           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10439 #else
10440           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10441 #endif
10442         else
10443 #ifdef MOMENT
10444           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10445 #else
10446           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10447 #endif
10448         endif
10449       endif
10450 ! Derivatives in gamma(k-1)
10451 #ifdef MOMENT
10452       if (imat.eq.1) then
10453         s1=dip(3,jj,i)*dipderg(2,kk,k)
10454       else
10455         s1=dip(2,jj,j)*dipderg(4,kk,l)
10456       endif
10457 #endif
10458       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10459       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10460       if (j.eq.l+1) then
10461         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10462         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10463       else
10464         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10465         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10466       endif
10467       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10468       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10469       vv(1)=pizda(1,1)-pizda(2,2)
10470       vv(2)=pizda(2,1)+pizda(1,2)
10471       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10472       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10473 #ifdef MOMENT
10474         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10475 #else
10476         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10477 #endif
10478       else
10479 #ifdef MOMENT
10480         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10481 #else
10482         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10483 #endif
10484       endif
10485 ! Derivatives in gamma(j-1) or gamma(l-1)
10486       if (l.eq.j+1 .and. l.gt.1) then
10487         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10488         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10489         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10490         vv(1)=pizda(1,1)-pizda(2,2)
10491         vv(2)=pizda(2,1)+pizda(1,2)
10492         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10493         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10494       else if (j.gt.1) then
10495         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10496         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10497         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10498         vv(1)=pizda(1,1)-pizda(2,2)
10499         vv(2)=pizda(2,1)+pizda(1,2)
10500         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10501         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10502           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10503         else
10504           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10505         endif
10506       endif
10507 ! Cartesian derivatives.
10508       do iii=1,2
10509         do kkk=1,5
10510           do lll=1,3
10511 #ifdef MOMENT
10512             if (iii.eq.1) then
10513               if (imat.eq.1) then
10514                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10515               else
10516                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10517               endif
10518             else
10519               if (imat.eq.1) then
10520                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10521               else
10522                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10523               endif
10524             endif
10525 #endif
10526             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10527               auxvec(1))
10528             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10529             if (j.eq.l+1) then
10530               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10531                 b1(1,itj1),auxvec(1))
10532               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10533             else
10534               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10535                 b1(1,itl1),auxvec(1))
10536               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10537             endif
10538             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10539               pizda(1,1))
10540             vv(1)=pizda(1,1)-pizda(2,2)
10541             vv(2)=pizda(2,1)+pizda(1,2)
10542             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10543             if (swap) then
10544               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10545 #ifdef MOMENT
10546                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10547                    -(s1+s2+s4)
10548 #else
10549                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10550                    -(s2+s4)
10551 #endif
10552                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10553               else
10554 #ifdef MOMENT
10555                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10556 #else
10557                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10558 #endif
10559                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10560               endif
10561             else
10562 #ifdef MOMENT
10563               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10564 #else
10565               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10566 #endif
10567               if (l.eq.j+1) then
10568                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10569               else
10570                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10571               endif
10572             endif
10573           enddo
10574         enddo
10575       enddo
10576       return
10577       end function eello6_graph4
10578 !-----------------------------------------------------------------------------
10579       real(kind=8) function eello_turn6(i,jj,kk)
10580 !      implicit real*8 (a-h,o-z)
10581 !      include 'DIMENSIONS'
10582 !      include 'COMMON.IOUNITS'
10583 !      include 'COMMON.CHAIN'
10584 !      include 'COMMON.DERIV'
10585 !      include 'COMMON.INTERACT'
10586 !      include 'COMMON.CONTACTS'
10587 !      include 'COMMON.TORSION'
10588 !      include 'COMMON.VAR'
10589 !      include 'COMMON.GEO'
10590       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10591       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10592       real(kind=8),dimension(3) :: ggg1,ggg2
10593       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10594       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10595 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10596 !           the respective energy moment and not to the cluster cumulant.
10597 !el local variables
10598       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10599       integer :: j1,j2,l1,l2,ll
10600       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10601       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10602       s1=0.0d0
10603       s8=0.0d0
10604       s13=0.0d0
10605 !
10606       eello_turn6=0.0d0
10607       j=i+4
10608       k=i+1
10609       l=i+3
10610       iti=itortyp(itype(i,1))
10611       itk=itortyp(itype(k,1))
10612       itk1=itortyp(itype(k+1,1))
10613       itl=itortyp(itype(l,1))
10614       itj=itortyp(itype(j,1))
10615 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10616 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10617 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10618 !d        eello6=0.0d0
10619 !d        return
10620 !d      endif
10621 !d      write (iout,*)
10622 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10623 !d     &   ' and',k,l
10624 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10625       do iii=1,2
10626         do kkk=1,5
10627           do lll=1,3
10628             derx_turn(lll,kkk,iii)=0.0d0
10629           enddo
10630         enddo
10631       enddo
10632 !d      eij=1.0d0
10633 !d      ekl=1.0d0
10634 !d      ekont=1.0d0
10635       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10636 !d      eello6_5=0.0d0
10637 !d      write (2,*) 'eello6_5',eello6_5
10638 #ifdef MOMENT
10639       call transpose2(AEA(1,1,1),auxmat(1,1))
10640       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10641       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10642       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10643 #endif
10644       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10645       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10646       s2 = scalar2(b1(1,itk),vtemp1(1))
10647 #ifdef MOMENT
10648       call transpose2(AEA(1,1,2),atemp(1,1))
10649       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10650       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10651       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10652 #endif
10653       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10654       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10655       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10656 #ifdef MOMENT
10657       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10658       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10659       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10660       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10661       ss13 = scalar2(b1(1,itk),vtemp4(1))
10662       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10663 #endif
10664 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10665 !      s1=0.0d0
10666 !      s2=0.0d0
10667 !      s8=0.0d0
10668 !      s12=0.0d0
10669 !      s13=0.0d0
10670       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10671 ! Derivatives in gamma(i+2)
10672       s1d =0.0d0
10673       s8d =0.0d0
10674 #ifdef MOMENT
10675       call transpose2(AEA(1,1,1),auxmatd(1,1))
10676       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10677       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10678       call transpose2(AEAderg(1,1,2),atempd(1,1))
10679       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10680       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10681 #endif
10682       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10683       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10684       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10685 !      s1d=0.0d0
10686 !      s2d=0.0d0
10687 !      s8d=0.0d0
10688 !      s12d=0.0d0
10689 !      s13d=0.0d0
10690       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10691 ! Derivatives in gamma(i+3)
10692 #ifdef MOMENT
10693       call transpose2(AEA(1,1,1),auxmatd(1,1))
10694       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10695       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10696       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10697 #endif
10698       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10699       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10700       s2d = scalar2(b1(1,itk),vtemp1d(1))
10701 #ifdef MOMENT
10702       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10703       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10704 #endif
10705       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10706 #ifdef MOMENT
10707       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10708       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10709       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10710 #endif
10711 !      s1d=0.0d0
10712 !      s2d=0.0d0
10713 !      s8d=0.0d0
10714 !      s12d=0.0d0
10715 !      s13d=0.0d0
10716 #ifdef MOMENT
10717       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10718                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10719 #else
10720       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10721                     -0.5d0*ekont*(s2d+s12d)
10722 #endif
10723 ! Derivatives in gamma(i+4)
10724       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10725       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10726       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10727 #ifdef MOMENT
10728       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10729       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10730       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10731 #endif
10732 !      s1d=0.0d0
10733 !      s2d=0.0d0
10734 !      s8d=0.0d0
10735 !      s12d=0.0d0
10736 !      s13d=0.0d0
10737 #ifdef MOMENT
10738       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10739 #else
10740       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10741 #endif
10742 ! Derivatives in gamma(i+5)
10743 #ifdef MOMENT
10744       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10745       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10746       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10747 #endif
10748       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10749       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10750       s2d = scalar2(b1(1,itk),vtemp1d(1))
10751 #ifdef MOMENT
10752       call transpose2(AEA(1,1,2),atempd(1,1))
10753       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10754       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10755 #endif
10756       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10757       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10758 #ifdef MOMENT
10759       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10760       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10761       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10762 #endif
10763 !      s1d=0.0d0
10764 !      s2d=0.0d0
10765 !      s8d=0.0d0
10766 !      s12d=0.0d0
10767 !      s13d=0.0d0
10768 #ifdef MOMENT
10769       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10770                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10771 #else
10772       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10773                     -0.5d0*ekont*(s2d+s12d)
10774 #endif
10775 ! Cartesian derivatives
10776       do iii=1,2
10777         do kkk=1,5
10778           do lll=1,3
10779 #ifdef MOMENT
10780             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10781             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10782             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10783 #endif
10784             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10785             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10786                 vtemp1d(1))
10787             s2d = scalar2(b1(1,itk),vtemp1d(1))
10788 #ifdef MOMENT
10789             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10790             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10791             s8d = -(atempd(1,1)+atempd(2,2))* &
10792                  scalar2(cc(1,1,itl),vtemp2(1))
10793 #endif
10794             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10795                  auxmatd(1,1))
10796             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10797             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10798 !      s1d=0.0d0
10799 !      s2d=0.0d0
10800 !      s8d=0.0d0
10801 !      s12d=0.0d0
10802 !      s13d=0.0d0
10803 #ifdef MOMENT
10804             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10805               - 0.5d0*(s1d+s2d)
10806 #else
10807             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10808               - 0.5d0*s2d
10809 #endif
10810 #ifdef MOMENT
10811             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10812               - 0.5d0*(s8d+s12d)
10813 #else
10814             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10815               - 0.5d0*s12d
10816 #endif
10817           enddo
10818         enddo
10819       enddo
10820 #ifdef MOMENT
10821       do kkk=1,5
10822         do lll=1,3
10823           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10824             achuj_tempd(1,1))
10825           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10826           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10827           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10828           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10829           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10830             vtemp4d(1))
10831           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10832           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10833           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10834         enddo
10835       enddo
10836 #endif
10837 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10838 !d     &  16*eel_turn6_num
10839 !d      goto 1112
10840       if (j.lt.nres-1) then
10841         j1=j+1
10842         j2=j-1
10843       else
10844         j1=j-1
10845         j2=j-2
10846       endif
10847       if (l.lt.nres-1) then
10848         l1=l+1
10849         l2=l-1
10850       else
10851         l1=l-1
10852         l2=l-2
10853       endif
10854       do ll=1,3
10855 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10856 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10857 !grad        ghalf=0.5d0*ggg1(ll)
10858 !d        ghalf=0.0d0
10859         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10860         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10861         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10862           +ekont*derx_turn(ll,2,1)
10863         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10864         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10865           +ekont*derx_turn(ll,4,1)
10866         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10867         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10868         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10869 !grad        ghalf=0.5d0*ggg2(ll)
10870 !d        ghalf=0.0d0
10871         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10872           +ekont*derx_turn(ll,2,2)
10873         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10874         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10875           +ekont*derx_turn(ll,4,2)
10876         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10877         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10878         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10879       enddo
10880 !d      goto 1112
10881 !grad      do m=i+1,j-1
10882 !grad        do ll=1,3
10883 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10884 !grad        enddo
10885 !grad      enddo
10886 !grad      do m=k+1,l-1
10887 !grad        do ll=1,3
10888 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10889 !grad        enddo
10890 !grad      enddo
10891 !grad1112  continue
10892 !grad      do m=i+2,j2
10893 !grad        do ll=1,3
10894 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10895 !grad        enddo
10896 !grad      enddo
10897 !grad      do m=k+2,l2
10898 !grad        do ll=1,3
10899 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10900 !grad        enddo
10901 !grad      enddo
10902 !d      do iii=1,nres-3
10903 !d        write (2,*) iii,g_corr6_loc(iii)
10904 !d      enddo
10905       eello_turn6=ekont*eel_turn6
10906 !d      write (2,*) 'ekont',ekont
10907 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10908       return
10909       end function eello_turn6
10910 !-----------------------------------------------------------------------------
10911       subroutine MATVEC2(A1,V1,V2)
10912 !DIR$ INLINEALWAYS MATVEC2
10913 #ifndef OSF
10914 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10915 #endif
10916 !      implicit real*8 (a-h,o-z)
10917 !      include 'DIMENSIONS'
10918       real(kind=8),dimension(2) :: V1,V2
10919       real(kind=8),dimension(2,2) :: A1
10920       real(kind=8) :: vaux1,vaux2
10921 !      DO 1 I=1,2
10922 !        VI=0.0
10923 !        DO 3 K=1,2
10924 !    3     VI=VI+A1(I,K)*V1(K)
10925 !        Vaux(I)=VI
10926 !    1 CONTINUE
10927
10928       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10929       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10930
10931       v2(1)=vaux1
10932       v2(2)=vaux2
10933       end subroutine MATVEC2
10934 !-----------------------------------------------------------------------------
10935       subroutine MATMAT2(A1,A2,A3)
10936 #ifndef OSF
10937 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10938 #endif
10939 !      implicit real*8 (a-h,o-z)
10940 !      include 'DIMENSIONS'
10941       real(kind=8),dimension(2,2) :: A1,A2,A3
10942       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10943 !      DIMENSION AI3(2,2)
10944 !        DO  J=1,2
10945 !          A3IJ=0.0
10946 !          DO K=1,2
10947 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10948 !          enddo
10949 !          A3(I,J)=A3IJ
10950 !       enddo
10951 !      enddo
10952
10953       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10954       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10955       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10956       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10957
10958       A3(1,1)=AI3_11
10959       A3(2,1)=AI3_21
10960       A3(1,2)=AI3_12
10961       A3(2,2)=AI3_22
10962       end subroutine MATMAT2
10963 !-----------------------------------------------------------------------------
10964       real(kind=8) function scalar2(u,v)
10965 !DIR$ INLINEALWAYS scalar2
10966       implicit none
10967       real(kind=8),dimension(2) :: u,v
10968       real(kind=8) :: sc
10969       integer :: i
10970       scalar2=u(1)*v(1)+u(2)*v(2)
10971       return
10972       end function scalar2
10973 !-----------------------------------------------------------------------------
10974       subroutine transpose2(a,at)
10975 !DIR$ INLINEALWAYS transpose2
10976 #ifndef OSF
10977 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10978 #endif
10979       implicit none
10980       real(kind=8),dimension(2,2) :: a,at
10981       at(1,1)=a(1,1)
10982       at(1,2)=a(2,1)
10983       at(2,1)=a(1,2)
10984       at(2,2)=a(2,2)
10985       return
10986       end subroutine transpose2
10987 !-----------------------------------------------------------------------------
10988       subroutine transpose(n,a,at)
10989       implicit none
10990       integer :: n,i,j
10991       real(kind=8),dimension(n,n) :: a,at
10992       do i=1,n
10993         do j=1,n
10994           at(j,i)=a(i,j)
10995         enddo
10996       enddo
10997       return
10998       end subroutine transpose
10999 !-----------------------------------------------------------------------------
11000       subroutine prodmat3(a1,a2,kk,transp,prod)
11001 !DIR$ INLINEALWAYS prodmat3
11002 #ifndef OSF
11003 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11004 #endif
11005       implicit none
11006       integer :: i,j
11007       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11008       logical :: transp
11009 !rc      double precision auxmat(2,2),prod_(2,2)
11010
11011       if (transp) then
11012 !rc        call transpose2(kk(1,1),auxmat(1,1))
11013 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11014 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11015
11016            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11017        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11018            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11019        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11020            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11021        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11022            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11023        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11024
11025       else
11026 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11027 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11028
11029            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11030         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11031            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11032         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11033            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11034         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11035            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11036         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11037
11038       endif
11039 !      call transpose2(a2(1,1),a2t(1,1))
11040
11041 !rc      print *,transp
11042 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11043 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11044
11045       return
11046       end subroutine prodmat3
11047 !-----------------------------------------------------------------------------
11048 ! energy_p_new_barrier.F
11049 !-----------------------------------------------------------------------------
11050       subroutine sum_gradient
11051 !      implicit real*8 (a-h,o-z)
11052       use io_base, only: pdbout
11053 !      include 'DIMENSIONS'
11054 #ifndef ISNAN
11055       external proc_proc
11056 #ifdef WINPGI
11057 !MS$ATTRIBUTES C ::  proc_proc
11058 #endif
11059 #endif
11060 #ifdef MPI
11061       include 'mpif.h'
11062 #endif
11063       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11064                    gloc_scbuf !(3,maxres)
11065
11066       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11067 !#endif
11068 !el local variables
11069       integer :: i,j,k,ierror,ierr
11070       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11071                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11072                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11073                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11074                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11075                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11076                    gsccorr_max,gsccorrx_max,time00
11077
11078 !      include 'COMMON.SETUP'
11079 !      include 'COMMON.IOUNITS'
11080 !      include 'COMMON.FFIELD'
11081 !      include 'COMMON.DERIV'
11082 !      include 'COMMON.INTERACT'
11083 !      include 'COMMON.SBRIDGE'
11084 !      include 'COMMON.CHAIN'
11085 !      include 'COMMON.VAR'
11086 !      include 'COMMON.CONTROL'
11087 !      include 'COMMON.TIME1'
11088 !      include 'COMMON.MAXGRAD'
11089 !      include 'COMMON.SCCOR'
11090 #ifdef TIMING
11091       time01=MPI_Wtime()
11092 #endif
11093 !#define DEBUG
11094 #ifdef DEBUG
11095       write (iout,*) "sum_gradient gvdwc, gvdwx"
11096       do i=1,nres
11097         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11098          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11099       enddo
11100       call flush(iout)
11101 #endif
11102 #ifdef MPI
11103         gradbufc=0.0d0
11104         gradbufx=0.0d0
11105         gradbufc_sum=0.0d0
11106         gloc_scbuf=0.0d0
11107         glocbuf=0.0d0
11108 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11109         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11110           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11111 #endif
11112 !
11113 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11114 !            in virtual-bond-vector coordinates
11115 !
11116 #ifdef DEBUG
11117 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11118 !      do i=1,nres-1
11119 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11120 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11121 !      enddo
11122 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11123 !      do i=1,nres-1
11124 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11125 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11126 !      enddo
11127 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11128 !      do i=1,nres
11129 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11130 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11131 !         (gvdwc_scpp(j,i),j=1,3)
11132 !      enddo
11133 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11134 !      do i=1,nres
11135 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11136 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11137 !         (gelc_loc_long(j,i),j=1,3)
11138 !      enddo
11139       call flush(iout)
11140 #endif
11141 #ifdef SPLITELE
11142       do i=0,nct
11143         do j=1,3
11144           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11145                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11146                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11147                       wel_loc*gel_loc_long(j,i)+ &
11148                       wcorr*gradcorr_long(j,i)+ &
11149                       wcorr5*gradcorr5_long(j,i)+ &
11150                       wcorr6*gradcorr6_long(j,i)+ &
11151                       wturn6*gcorr6_turn_long(j,i)+ &
11152                       wstrain*ghpbc(j,i) &
11153                      +wliptran*gliptranc(j,i) &
11154                      +gradafm(j,i) &
11155                      +welec*gshieldc(j,i) &
11156                      +wcorr*gshieldc_ec(j,i) &
11157                      +wturn3*gshieldc_t3(j,i)&
11158                      +wturn4*gshieldc_t4(j,i)&
11159                      +wel_loc*gshieldc_ll(j,i)&
11160                      +wtube*gg_tube(j,i) &
11161                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11162                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11163                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11164                      wcorr_nucl*gradcorr_nucl(j,i)&
11165                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11166                      wcatprot* gradpepcat(j,i)+ &
11167                      wcatcat*gradcatcat(j,i)+   &
11168                      wscbase*gvdwc_scbase(j,i)+ &
11169                      wpepbase*gvdwc_pepbase(j,i)+&
11170                      wscpho*gvdwc_scpho(j,i)+   &
11171                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11172
11173
11174
11175
11176
11177         enddo
11178       enddo
11179 #else
11180       do i=0,nct
11181         do j=1,3
11182           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11183                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11184                       welec*gelc_long(j,i)+ &
11185                       wbond*gradb(j,i)+ &
11186                       wel_loc*gel_loc_long(j,i)+ &
11187                       wcorr*gradcorr_long(j,i)+ &
11188                       wcorr5*gradcorr5_long(j,i)+ &
11189                       wcorr6*gradcorr6_long(j,i)+ &
11190                       wturn6*gcorr6_turn_long(j,i)+ &
11191                       wstrain*ghpbc(j,i) &
11192                      +wliptran*gliptranc(j,i) &
11193                      +gradafm(j,i) &
11194                      +welec*gshieldc(j,i)&
11195                      +wcorr*gshieldc_ec(j,i) &
11196                      +wturn4*gshieldc_t4(j,i) &
11197                      +wel_loc*gshieldc_ll(j,i)&
11198                      +wtube*gg_tube(j,i) &
11199                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11200                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11201                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11202                      wcorr_nucl*gradcorr_nucl(j,i) &
11203                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11204                      wcatprot* gradpepcat(j,i)+ &
11205                      wcatcat*gradcatcat(j,i)+   &
11206                      wscbase*gvdwc_scbase(j,i)+ &
11207                      wpepbase*gvdwc_pepbase(j,i)+&
11208                      wscpho*gvdwc_scpho(j,i)+&
11209                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11210
11211
11212         enddo
11213       enddo
11214 #endif
11215 #ifdef MPI
11216       if (nfgtasks.gt.1) then
11217       time00=MPI_Wtime()
11218 #ifdef DEBUG
11219       write (iout,*) "gradbufc before allreduce"
11220       do i=1,nres
11221         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11222       enddo
11223       call flush(iout)
11224 #endif
11225       do i=0,nres
11226         do j=1,3
11227           gradbufc_sum(j,i)=gradbufc(j,i)
11228         enddo
11229       enddo
11230 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11231 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11232 !      time_reduce=time_reduce+MPI_Wtime()-time00
11233 #ifdef DEBUG
11234 !      write (iout,*) "gradbufc_sum after allreduce"
11235 !      do i=1,nres
11236 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11237 !      enddo
11238 !      call flush(iout)
11239 #endif
11240 #ifdef TIMING
11241 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11242 #endif
11243       do i=0,nres
11244         do k=1,3
11245           gradbufc(k,i)=0.0d0
11246         enddo
11247       enddo
11248 #ifdef DEBUG
11249       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11250       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11251                         " jgrad_end  ",jgrad_end(i),&
11252                         i=igrad_start,igrad_end)
11253 #endif
11254 !
11255 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11256 ! do not parallelize this part.
11257 !
11258 !      do i=igrad_start,igrad_end
11259 !        do j=jgrad_start(i),jgrad_end(i)
11260 !          do k=1,3
11261 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11262 !          enddo
11263 !        enddo
11264 !      enddo
11265       do j=1,3
11266         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11267       enddo
11268       do i=nres-2,-1,-1
11269         do j=1,3
11270           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11271         enddo
11272       enddo
11273 #ifdef DEBUG
11274       write (iout,*) "gradbufc after summing"
11275       do i=1,nres
11276         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11277       enddo
11278       call flush(iout)
11279 #endif
11280       else
11281 #endif
11282 !el#define DEBUG
11283 #ifdef DEBUG
11284       write (iout,*) "gradbufc"
11285       do i=1,nres
11286         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11287       enddo
11288       call flush(iout)
11289 #endif
11290 !el#undef DEBUG
11291       do i=-1,nres
11292         do j=1,3
11293           gradbufc_sum(j,i)=gradbufc(j,i)
11294           gradbufc(j,i)=0.0d0
11295         enddo
11296       enddo
11297       do j=1,3
11298         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11299       enddo
11300       do i=nres-2,-1,-1
11301         do j=1,3
11302           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11303         enddo
11304       enddo
11305 !      do i=nnt,nres-1
11306 !        do k=1,3
11307 !          gradbufc(k,i)=0.0d0
11308 !        enddo
11309 !        do j=i+1,nres
11310 !          do k=1,3
11311 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11312 !          enddo
11313 !        enddo
11314 !      enddo
11315 !el#define DEBUG
11316 #ifdef DEBUG
11317       write (iout,*) "gradbufc after summing"
11318       do i=1,nres
11319         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11320       enddo
11321       call flush(iout)
11322 #endif
11323 !el#undef DEBUG
11324 #ifdef MPI
11325       endif
11326 #endif
11327       do k=1,3
11328         gradbufc(k,nres)=0.0d0
11329       enddo
11330 !el----------------
11331 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11332 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11333 !el-----------------
11334       do i=-1,nct
11335         do j=1,3
11336 #ifdef SPLITELE
11337           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11338                       wel_loc*gel_loc(j,i)+ &
11339                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11340                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11341                       wel_loc*gel_loc_long(j,i)+ &
11342                       wcorr*gradcorr_long(j,i)+ &
11343                       wcorr5*gradcorr5_long(j,i)+ &
11344                       wcorr6*gradcorr6_long(j,i)+ &
11345                       wturn6*gcorr6_turn_long(j,i))+ &
11346                       wbond*gradb(j,i)+ &
11347                       wcorr*gradcorr(j,i)+ &
11348                       wturn3*gcorr3_turn(j,i)+ &
11349                       wturn4*gcorr4_turn(j,i)+ &
11350                       wcorr5*gradcorr5(j,i)+ &
11351                       wcorr6*gradcorr6(j,i)+ &
11352                       wturn6*gcorr6_turn(j,i)+ &
11353                       wsccor*gsccorc(j,i) &
11354                      +wscloc*gscloc(j,i)  &
11355                      +wliptran*gliptranc(j,i) &
11356                      +gradafm(j,i) &
11357                      +welec*gshieldc(j,i) &
11358                      +welec*gshieldc_loc(j,i) &
11359                      +wcorr*gshieldc_ec(j,i) &
11360                      +wcorr*gshieldc_loc_ec(j,i) &
11361                      +wturn3*gshieldc_t3(j,i) &
11362                      +wturn3*gshieldc_loc_t3(j,i) &
11363                      +wturn4*gshieldc_t4(j,i) &
11364                      +wturn4*gshieldc_loc_t4(j,i) &
11365                      +wel_loc*gshieldc_ll(j,i) &
11366                      +wel_loc*gshieldc_loc_ll(j,i) &
11367                      +wtube*gg_tube(j,i) &
11368                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11369                      +wvdwpsb*gvdwpsb1(j,i))&
11370                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11371 !                      if (i.eq.21) then
11372 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11373 !                      wturn4*gshieldc_t4(j,i), &
11374 !                     wturn4*gshieldc_loc_t4(j,i)
11375 !                       endif
11376 !                 if ((i.le.2).and.(i.ge.1))
11377 !                       print *,gradc(j,i,icg),&
11378 !                      gradbufc(j,i),welec*gelc(j,i), &
11379 !                      wel_loc*gel_loc(j,i), &
11380 !                      wscp*gvdwc_scpp(j,i), &
11381 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11382 !                      wel_loc*gel_loc_long(j,i), &
11383 !                      wcorr*gradcorr_long(j,i), &
11384 !                      wcorr5*gradcorr5_long(j,i), &
11385 !                      wcorr6*gradcorr6_long(j,i), &
11386 !                      wturn6*gcorr6_turn_long(j,i), &
11387 !                      wbond*gradb(j,i), &
11388 !                      wcorr*gradcorr(j,i), &
11389 !                      wturn3*gcorr3_turn(j,i), &
11390 !                      wturn4*gcorr4_turn(j,i), &
11391 !                      wcorr5*gradcorr5(j,i), &
11392 !                      wcorr6*gradcorr6(j,i), &
11393 !                      wturn6*gcorr6_turn(j,i), &
11394 !                      wsccor*gsccorc(j,i) &
11395 !                     ,wscloc*gscloc(j,i)  &
11396 !                     ,wliptran*gliptranc(j,i) &
11397 !                    ,gradafm(j,i) &
11398 !                     ,welec*gshieldc(j,i) &
11399 !                     ,welec*gshieldc_loc(j,i) &
11400 !                     ,wcorr*gshieldc_ec(j,i) &
11401 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11402 !                     ,wturn3*gshieldc_t3(j,i) &
11403 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11404 !                     ,wturn4*gshieldc_t4(j,i) &
11405 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11406 !                     ,wel_loc*gshieldc_ll(j,i) &
11407 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11408 !                     ,wtube*gg_tube(j,i) &
11409 !                     ,wbond_nucl*gradb_nucl(j,i) &
11410 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11411 !                     wvdwpsb*gvdwpsb1(j,i)&
11412 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11413 !
11414
11415 #else
11416           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11417                       wel_loc*gel_loc(j,i)+ &
11418                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11419                       welec*gelc_long(j,i)+ &
11420                       wel_loc*gel_loc_long(j,i)+ &
11421 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11422                       wcorr5*gradcorr5_long(j,i)+ &
11423                       wcorr6*gradcorr6_long(j,i)+ &
11424                       wturn6*gcorr6_turn_long(j,i))+ &
11425                       wbond*gradb(j,i)+ &
11426                       wcorr*gradcorr(j,i)+ &
11427                       wturn3*gcorr3_turn(j,i)+ &
11428                       wturn4*gcorr4_turn(j,i)+ &
11429                       wcorr5*gradcorr5(j,i)+ &
11430                       wcorr6*gradcorr6(j,i)+ &
11431                       wturn6*gcorr6_turn(j,i)+ &
11432                       wsccor*gsccorc(j,i) &
11433                      +wscloc*gscloc(j,i) &
11434                      +gradafm(j,i) &
11435                      +wliptran*gliptranc(j,i) &
11436                      +welec*gshieldc(j,i) &
11437                      +welec*gshieldc_loc(j,i) &
11438                      +wcorr*gshieldc_ec(j,i) &
11439                      +wcorr*gshieldc_loc_ec(j,i) &
11440                      +wturn3*gshieldc_t3(j,i) &
11441                      +wturn3*gshieldc_loc_t3(j,i) &
11442                      +wturn4*gshieldc_t4(j,i) &
11443                      +wturn4*gshieldc_loc_t4(j,i) &
11444                      +wel_loc*gshieldc_ll(j,i) &
11445                      +wel_loc*gshieldc_loc_ll(j,i) &
11446                      +wtube*gg_tube(j,i) &
11447                      +wbond_nucl*gradb_nucl(j,i) &
11448                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11449                      +wvdwpsb*gvdwpsb1(j,i))&
11450                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)
11451
11452
11453
11454
11455 #endif
11456           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11457                         wbond*gradbx(j,i)+ &
11458                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11459                         wsccor*gsccorx(j,i) &
11460                        +wscloc*gsclocx(j,i) &
11461                        +wliptran*gliptranx(j,i) &
11462                        +welec*gshieldx(j,i)     &
11463                        +wcorr*gshieldx_ec(j,i)  &
11464                        +wturn3*gshieldx_t3(j,i) &
11465                        +wturn4*gshieldx_t4(j,i) &
11466                        +wel_loc*gshieldx_ll(j,i)&
11467                        +wtube*gg_tube_sc(j,i)   &
11468                        +wbond_nucl*gradbx_nucl(j,i) &
11469                        +wvdwsb*gvdwsbx(j,i) &
11470                        +welsb*gelsbx(j,i) &
11471                        +wcorr_nucl*gradxorr_nucl(j,i)&
11472                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11473                        +wsbloc*gsblocx(j,i) &
11474                        +wcatprot* gradpepcatx(j,i)&
11475                        +wscbase*gvdwx_scbase(j,i) &
11476                        +wpepbase*gvdwx_pepbase(j,i)&
11477                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)
11478 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11479
11480         enddo
11481       enddo
11482 !#define DEBUG
11483 #ifdef DEBUG
11484       write (iout,*) "gloc before adding corr"
11485       do i=1,4*nres
11486         write (iout,*) i,gloc(i,icg)
11487       enddo
11488 #endif
11489       do i=1,nres-3
11490         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11491          +wcorr5*g_corr5_loc(i) &
11492          +wcorr6*g_corr6_loc(i) &
11493          +wturn4*gel_loc_turn4(i) &
11494          +wturn3*gel_loc_turn3(i) &
11495          +wturn6*gel_loc_turn6(i) &
11496          +wel_loc*gel_loc_loc(i)
11497       enddo
11498 #ifdef DEBUG
11499       write (iout,*) "gloc after adding corr"
11500       do i=1,4*nres
11501         write (iout,*) i,gloc(i,icg)
11502       enddo
11503 #endif
11504 !#undef DEBUG
11505 #ifdef MPI
11506       if (nfgtasks.gt.1) then
11507         do j=1,3
11508           do i=0,nres
11509             gradbufc(j,i)=gradc(j,i,icg)
11510             gradbufx(j,i)=gradx(j,i,icg)
11511           enddo
11512         enddo
11513         do i=1,4*nres
11514           glocbuf(i)=gloc(i,icg)
11515         enddo
11516 !#define DEBUG
11517 #ifdef DEBUG
11518       write (iout,*) "gloc_sc before reduce"
11519       do i=1,nres
11520        do j=1,1
11521         write (iout,*) i,j,gloc_sc(j,i,icg)
11522        enddo
11523       enddo
11524 #endif
11525 !#undef DEBUG
11526         do i=0,nres
11527          do j=1,3
11528           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11529          enddo
11530         enddo
11531         time00=MPI_Wtime()
11532         call MPI_Barrier(FG_COMM,IERR)
11533         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11534         time00=MPI_Wtime()
11535         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11536           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11537         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11538           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11539         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11540           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11541         time_reduce=time_reduce+MPI_Wtime()-time00
11542         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
11543           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11544         time_reduce=time_reduce+MPI_Wtime()-time00
11545 !#define DEBUG
11546 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11547 #ifdef DEBUG
11548       write (iout,*) "gloc_sc after reduce"
11549       do i=0,nres
11550        do j=1,1
11551         write (iout,*) i,j,gloc_sc(j,i,icg)
11552        enddo
11553       enddo
11554 #endif
11555 !#undef DEBUG
11556 #ifdef DEBUG
11557       write (iout,*) "gloc after reduce"
11558       do i=1,4*nres
11559         write (iout,*) i,gloc(i,icg)
11560       enddo
11561 #endif
11562       endif
11563 #endif
11564       if (gnorm_check) then
11565 !
11566 ! Compute the maximum elements of the gradient
11567 !
11568       gvdwc_max=0.0d0
11569       gvdwc_scp_max=0.0d0
11570       gelc_max=0.0d0
11571       gvdwpp_max=0.0d0
11572       gradb_max=0.0d0
11573       ghpbc_max=0.0d0
11574       gradcorr_max=0.0d0
11575       gel_loc_max=0.0d0
11576       gcorr3_turn_max=0.0d0
11577       gcorr4_turn_max=0.0d0
11578       gradcorr5_max=0.0d0
11579       gradcorr6_max=0.0d0
11580       gcorr6_turn_max=0.0d0
11581       gsccorc_max=0.0d0
11582       gscloc_max=0.0d0
11583       gvdwx_max=0.0d0
11584       gradx_scp_max=0.0d0
11585       ghpbx_max=0.0d0
11586       gradxorr_max=0.0d0
11587       gsccorx_max=0.0d0
11588       gsclocx_max=0.0d0
11589       do i=1,nct
11590         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11591         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11592         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11593         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11594          gvdwc_scp_max=gvdwc_scp_norm
11595         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11596         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11597         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11598         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11599         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11600         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11601         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11602         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11603         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11604         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11605         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11606         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11607         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11608           gcorr3_turn(1,i)))
11609         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11610           gcorr3_turn_max=gcorr3_turn_norm
11611         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11612           gcorr4_turn(1,i)))
11613         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11614           gcorr4_turn_max=gcorr4_turn_norm
11615         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11616         if (gradcorr5_norm.gt.gradcorr5_max) &
11617           gradcorr5_max=gradcorr5_norm
11618         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11619         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11620         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11621           gcorr6_turn(1,i)))
11622         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11623           gcorr6_turn_max=gcorr6_turn_norm
11624         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11625         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11626         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11627         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11628         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11629         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11630         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11631         if (gradx_scp_norm.gt.gradx_scp_max) &
11632           gradx_scp_max=gradx_scp_norm
11633         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11634         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11635         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11636         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11637         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11638         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11639         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11640         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11641       enddo
11642       if (gradout) then
11643 #ifdef AIX
11644         open(istat,file=statname,position="append")
11645 #else
11646         open(istat,file=statname,access="append")
11647 #endif
11648         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11649            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11650            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11651            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11652            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11653            gsccorx_max,gsclocx_max
11654         close(istat)
11655         if (gvdwc_max.gt.1.0d4) then
11656           write (iout,*) "gvdwc gvdwx gradb gradbx"
11657           do i=nnt,nct
11658             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11659               gradb(j,i),gradbx(j,i),j=1,3)
11660           enddo
11661           call pdbout(0.0d0,'cipiszcze',iout)
11662           call flush(iout)
11663         endif
11664       endif
11665       endif
11666 !#define DEBUG
11667 #ifdef DEBUG
11668       write (iout,*) "gradc gradx gloc"
11669       do i=1,nres
11670         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11671          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11672       enddo
11673 #endif
11674 !#undef DEBUG
11675 #ifdef TIMING
11676       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11677 #endif
11678       return
11679       end subroutine sum_gradient
11680 !-----------------------------------------------------------------------------
11681       subroutine sc_grad
11682 !      implicit real*8 (a-h,o-z)
11683       use calc_data
11684 !      include 'DIMENSIONS'
11685 !      include 'COMMON.CHAIN'
11686 !      include 'COMMON.DERIV'
11687 !      include 'COMMON.CALC'
11688 !      include 'COMMON.IOUNITS'
11689       real(kind=8), dimension(3) :: dcosom1,dcosom2
11690 !      print *,"wchodze"
11691       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11692           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11693       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11694           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11695
11696       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11697            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11698            +dCAVdOM12+ dGCLdOM12
11699 ! diagnostics only
11700 !      eom1=0.0d0
11701 !      eom2=0.0d0
11702 !      eom12=evdwij*eps1_om12
11703 ! end diagnostics
11704 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11705 !       " sigder",sigder
11706 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11707 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11708 !C      print *,sss_ele_cut,'in sc_grad'
11709       do k=1,3
11710         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11711         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11712       enddo
11713       do k=1,3
11714         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11715 !C      print *,'gg',k,gg(k)
11716        enddo
11717 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11718 !      write (iout,*) "gg",(gg(k),k=1,3)
11719       do k=1,3
11720         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11721                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11722                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11723                   *sss_ele_cut
11724
11725         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11726                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11727                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11728                   *sss_ele_cut
11729
11730 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11731 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11732 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11733 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11734       enddo
11735 !
11736 ! Calculate the components of the gradient in DC and X
11737 !
11738 !grad      do k=i,j-1
11739 !grad        do l=1,3
11740 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11741 !grad        enddo
11742 !grad      enddo
11743       do l=1,3
11744         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11745         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11746       enddo
11747       return
11748       end subroutine sc_grad
11749
11750       subroutine sc_grad_cat
11751       use calc_data
11752       real(kind=8), dimension(3) :: dcosom1,dcosom2
11753       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11754           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11755       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11756           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11757
11758       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11759            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11760            +dCAVdOM12+ dGCLdOM12
11761 ! diagnostics only
11762 !      eom1=0.0d0
11763 !      eom2=0.0d0
11764 !      eom12=evdwij*eps1_om12
11765 ! end diagnostics
11766
11767       do k=1,3
11768         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11769         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11770       enddo
11771       do k=1,3
11772         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11773 !      print *,'gg',k,gg(k)
11774        enddo
11775 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11776 !      write (iout,*) "gg",(gg(k),k=1,3)
11777       do k=1,3
11778         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11779                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11780                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11781
11782 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11783 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11784 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11785
11786 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11787 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11788 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11789 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11790       enddo
11791 !
11792 ! Calculate the components of the gradient in DC and X
11793 !
11794       do l=1,3
11795         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11796         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11797       enddo
11798       end subroutine sc_grad_cat
11799
11800       subroutine sc_grad_cat_pep
11801       use calc_data
11802       real(kind=8), dimension(3) :: dcosom1,dcosom2
11803       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11804           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11805       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11806           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11807
11808       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11809            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11810            +dCAVdOM12+ dGCLdOM12
11811 ! diagnostics only
11812 !      eom1=0.0d0
11813 !      eom2=0.0d0
11814 !      eom12=evdwij*eps1_om12
11815 ! end diagnostics
11816
11817       do k=1,3
11818         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
11819         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
11820         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
11821         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
11822                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
11823                  *dsci_inv*2.0 &
11824                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11825         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
11826                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
11827                  *dsci_inv*2.0 &
11828                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11829         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
11830       enddo
11831       end subroutine sc_grad_cat_pep
11832
11833 #ifdef CRYST_THETA
11834 !-----------------------------------------------------------------------------
11835       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11836
11837       use comm_calcthet
11838 !      implicit real*8 (a-h,o-z)
11839 !      include 'DIMENSIONS'
11840 !      include 'COMMON.LOCAL'
11841 !      include 'COMMON.IOUNITS'
11842 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11843 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11844 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11845       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11846       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11847 !el      integer :: it
11848 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11849 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11850 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11851 !el local variables
11852
11853       delthec=thetai-thet_pred_mean
11854       delthe0=thetai-theta0i
11855 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11856       t3 = thetai-thet_pred_mean
11857       t6 = t3**2
11858       t9 = term1
11859       t12 = t3*sigcsq
11860       t14 = t12+t6*sigsqtc
11861       t16 = 1.0d0
11862       t21 = thetai-theta0i
11863       t23 = t21**2
11864       t26 = term2
11865       t27 = t21*t26
11866       t32 = termexp
11867       t40 = t32**2
11868       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11869        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11870        *(-t12*t9-ak*sig0inv*t27)
11871       return
11872       end subroutine mixder
11873 #endif
11874 !-----------------------------------------------------------------------------
11875 ! cartder.F
11876 !-----------------------------------------------------------------------------
11877       subroutine cartder
11878 !-----------------------------------------------------------------------------
11879 ! This subroutine calculates the derivatives of the consecutive virtual
11880 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11881 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11882 ! in the angles alpha and omega, describing the location of a side chain
11883 ! in its local coordinate system.
11884 !
11885 ! The derivatives are stored in the following arrays:
11886 !
11887 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11888 ! The structure is as follows:
11889 !
11890 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11891 ! 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)
11892 !         . . . . . . . . . . . .  . . . . . .
11893 ! 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)
11894 !                          .
11895 !                          .
11896 !                          .
11897 ! 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)
11898 !
11899 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11900 ! The structure is same as above.
11901 !
11902 ! DCDS - the derivatives of the side chain vectors in the local spherical
11903 ! andgles alph and omega:
11904 !
11905 ! 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)
11906 ! 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)
11907 !                          .
11908 !                          .
11909 !                          .
11910 ! 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)
11911 !
11912 ! Version of March '95, based on an early version of November '91.
11913 !
11914 !**********************************************************************
11915 !      implicit real*8 (a-h,o-z)
11916 !      include 'DIMENSIONS'
11917 !      include 'COMMON.VAR'
11918 !      include 'COMMON.CHAIN'
11919 !      include 'COMMON.DERIV'
11920 !      include 'COMMON.GEO'
11921 !      include 'COMMON.LOCAL'
11922 !      include 'COMMON.INTERACT'
11923       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11924       real(kind=8),dimension(3,3) :: dp,temp
11925 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11926       real(kind=8),dimension(3) :: xx,xx1
11927 !el local variables
11928       integer :: i,k,l,j,m,ind,ind1,jjj
11929       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11930                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11931                  sint2,xp,yp,xxp,yyp,zzp,dj
11932
11933 !      common /przechowalnia/ fromto
11934       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11935 ! get the position of the jth ijth fragment of the chain coordinate system
11936 ! in the fromto array.
11937 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11938 !
11939 !      maxdim=(nres-1)*(nres-2)/2
11940 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11941 ! calculate the derivatives of transformation matrix elements in theta
11942 !
11943
11944 !el      call flush(iout) !el
11945       do i=1,nres-2
11946         rdt(1,1,i)=-rt(1,2,i)
11947         rdt(1,2,i)= rt(1,1,i)
11948         rdt(1,3,i)= 0.0d0
11949         rdt(2,1,i)=-rt(2,2,i)
11950         rdt(2,2,i)= rt(2,1,i)
11951         rdt(2,3,i)= 0.0d0
11952         rdt(3,1,i)=-rt(3,2,i)
11953         rdt(3,2,i)= rt(3,1,i)
11954         rdt(3,3,i)= 0.0d0
11955       enddo
11956 !
11957 ! derivatives in phi
11958 !
11959       do i=2,nres-2
11960         drt(1,1,i)= 0.0d0
11961         drt(1,2,i)= 0.0d0
11962         drt(1,3,i)= 0.0d0
11963         drt(2,1,i)= rt(3,1,i)
11964         drt(2,2,i)= rt(3,2,i)
11965         drt(2,3,i)= rt(3,3,i)
11966         drt(3,1,i)=-rt(2,1,i)
11967         drt(3,2,i)=-rt(2,2,i)
11968         drt(3,3,i)=-rt(2,3,i)
11969       enddo
11970 !
11971 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11972 !
11973       do i=2,nres-2
11974         ind=indmat(i,i+1)
11975         do k=1,3
11976           do l=1,3
11977             temp(k,l)=rt(k,l,i)
11978           enddo
11979         enddo
11980         do k=1,3
11981           do l=1,3
11982             fromto(k,l,ind)=temp(k,l)
11983           enddo
11984         enddo
11985         do j=i+1,nres-2
11986           ind=indmat(i,j+1)
11987           do k=1,3
11988             do l=1,3
11989               dpkl=0.0d0
11990               do m=1,3
11991                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11992               enddo
11993               dp(k,l)=dpkl
11994               fromto(k,l,ind)=dpkl
11995             enddo
11996           enddo
11997           do k=1,3
11998             do l=1,3
11999               temp(k,l)=dp(k,l)
12000             enddo
12001           enddo
12002         enddo
12003       enddo
12004 !
12005 ! Calculate derivatives.
12006 !
12007       ind1=0
12008       do i=1,nres-2
12009       ind1=ind1+1
12010 !
12011 ! Derivatives of DC(i+1) in theta(i+2)
12012 !
12013         do j=1,3
12014           do k=1,2
12015             dpjk=0.0D0
12016             do l=1,3
12017               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12018             enddo
12019             dp(j,k)=dpjk
12020             prordt(j,k,i)=dp(j,k)
12021           enddo
12022           dp(j,3)=0.0D0
12023           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12024         enddo
12025 !
12026 ! Derivatives of SC(i+1) in theta(i+2)
12027 !
12028         xx1(1)=-0.5D0*xloc(2,i+1)
12029         xx1(2)= 0.5D0*xloc(1,i+1)
12030         do j=1,3
12031           xj=0.0D0
12032           do k=1,2
12033             xj=xj+r(j,k,i)*xx1(k)
12034           enddo
12035           xx(j)=xj
12036         enddo
12037         do j=1,3
12038           rj=0.0D0
12039           do k=1,3
12040             rj=rj+prod(j,k,i)*xx(k)
12041           enddo
12042           dxdv(j,ind1)=rj
12043         enddo
12044 !
12045 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12046 ! than the other off-diagonal derivatives.
12047 !
12048         do j=1,3
12049           dxoiij=0.0D0
12050           do k=1,3
12051             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12052           enddo
12053           dxdv(j,ind1+1)=dxoiij
12054         enddo
12055 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12056 !
12057 ! Derivatives of DC(i+1) in phi(i+2)
12058 !
12059         do j=1,3
12060           do k=1,3
12061             dpjk=0.0
12062             do l=2,3
12063               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12064             enddo
12065             dp(j,k)=dpjk
12066             prodrt(j,k,i)=dp(j,k)
12067           enddo
12068           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12069         enddo
12070 !
12071 ! Derivatives of SC(i+1) in phi(i+2)
12072 !
12073         xx(1)= 0.0D0
12074         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12075         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12076         do j=1,3
12077           rj=0.0D0
12078           do k=2,3
12079             rj=rj+prod(j,k,i)*xx(k)
12080           enddo
12081           dxdv(j+3,ind1)=-rj
12082         enddo
12083 !
12084 ! Derivatives of SC(i+1) in phi(i+3).
12085 !
12086         do j=1,3
12087           dxoiij=0.0D0
12088           do k=1,3
12089             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12090           enddo
12091           dxdv(j+3,ind1+1)=dxoiij
12092         enddo
12093 !
12094 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12095 ! theta(nres) and phi(i+3) thru phi(nres).
12096 !
12097         do j=i+1,nres-2
12098         ind1=ind1+1
12099         ind=indmat(i+1,j+1)
12100 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12101           do k=1,3
12102             do l=1,3
12103               tempkl=0.0D0
12104               do m=1,2
12105                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12106               enddo
12107               temp(k,l)=tempkl
12108             enddo
12109           enddo
12110 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12111 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12112 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12113 ! Derivatives of virtual-bond vectors in theta
12114           do k=1,3
12115             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12116           enddo
12117 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12118 ! Derivatives of SC vectors in theta
12119           do k=1,3
12120             dxoijk=0.0D0
12121             do l=1,3
12122               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12123             enddo
12124             dxdv(k,ind1+1)=dxoijk
12125           enddo
12126 !
12127 !--- Calculate the derivatives in phi
12128 !
12129           do k=1,3
12130             do l=1,3
12131               tempkl=0.0D0
12132               do m=1,3
12133                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12134               enddo
12135               temp(k,l)=tempkl
12136             enddo
12137           enddo
12138           do k=1,3
12139             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12140         enddo
12141           do k=1,3
12142             dxoijk=0.0D0
12143             do l=1,3
12144               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12145             enddo
12146             dxdv(k+3,ind1+1)=dxoijk
12147           enddo
12148         enddo
12149       enddo
12150 !
12151 ! Derivatives in alpha and omega:
12152 !
12153       do i=2,nres-1
12154 !       dsci=dsc(itype(i,1))
12155         dsci=vbld(i+nres)
12156 #ifdef OSF
12157         alphi=alph(i)
12158         omegi=omeg(i)
12159         if(alphi.ne.alphi) alphi=100.0
12160         if(omegi.ne.omegi) omegi=-100.0
12161 #else
12162       alphi=alph(i)
12163       omegi=omeg(i)
12164 #endif
12165 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12166       cosalphi=dcos(alphi)
12167       sinalphi=dsin(alphi)
12168       cosomegi=dcos(omegi)
12169       sinomegi=dsin(omegi)
12170       temp(1,1)=-dsci*sinalphi
12171       temp(2,1)= dsci*cosalphi*cosomegi
12172       temp(3,1)=-dsci*cosalphi*sinomegi
12173       temp(1,2)=0.0D0
12174       temp(2,2)=-dsci*sinalphi*sinomegi
12175       temp(3,2)=-dsci*sinalphi*cosomegi
12176       theta2=pi-0.5D0*theta(i+1)
12177       cost2=dcos(theta2)
12178       sint2=dsin(theta2)
12179       jjj=0
12180 !d      print *,((temp(l,k),l=1,3),k=1,2)
12181         do j=1,2
12182         xp=temp(1,j)
12183         yp=temp(2,j)
12184         xxp= xp*cost2+yp*sint2
12185         yyp=-xp*sint2+yp*cost2
12186         zzp=temp(3,j)
12187         xx(1)=xxp
12188         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12189         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12190         do k=1,3
12191           dj=0.0D0
12192           do l=1,3
12193             dj=dj+prod(k,l,i-1)*xx(l)
12194             enddo
12195           dxds(jjj+k,i)=dj
12196           enddo
12197         jjj=jjj+3
12198       enddo
12199       enddo
12200       return
12201       end subroutine cartder
12202 !-----------------------------------------------------------------------------
12203 ! checkder_p.F
12204 !-----------------------------------------------------------------------------
12205       subroutine check_cartgrad
12206 ! Check the gradient of Cartesian coordinates in internal coordinates.
12207 !      implicit real*8 (a-h,o-z)
12208 !      include 'DIMENSIONS'
12209 !      include 'COMMON.IOUNITS'
12210 !      include 'COMMON.VAR'
12211 !      include 'COMMON.CHAIN'
12212 !      include 'COMMON.GEO'
12213 !      include 'COMMON.LOCAL'
12214 !      include 'COMMON.DERIV'
12215       real(kind=8),dimension(6,nres) :: temp
12216       real(kind=8),dimension(3) :: xx,gg
12217       integer :: i,k,j,ii
12218       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12219 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12220 !
12221 ! Check the gradient of the virtual-bond and SC vectors in the internal
12222 ! coordinates.
12223 !
12224       aincr=1.0d-6
12225       aincr2=5.0d-7
12226       call cartder
12227       write (iout,'(a)') '**************** dx/dalpha'
12228       write (iout,'(a)')
12229       do i=2,nres-1
12230       alphi=alph(i)
12231       alph(i)=alph(i)+aincr
12232       do k=1,3
12233         temp(k,i)=dc(k,nres+i)
12234         enddo
12235       call chainbuild
12236       do k=1,3
12237         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12238         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12239         enddo
12240         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12241         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12242         write (iout,'(a)')
12243       alph(i)=alphi
12244       call chainbuild
12245       enddo
12246       write (iout,'(a)')
12247       write (iout,'(a)') '**************** dx/domega'
12248       write (iout,'(a)')
12249       do i=2,nres-1
12250       omegi=omeg(i)
12251       omeg(i)=omeg(i)+aincr
12252       do k=1,3
12253         temp(k,i)=dc(k,nres+i)
12254         enddo
12255       call chainbuild
12256       do k=1,3
12257           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12258           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12259                 (aincr*dabs(dxds(k+3,i))+aincr))
12260         enddo
12261         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12262             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12263         write (iout,'(a)')
12264       omeg(i)=omegi
12265       call chainbuild
12266       enddo
12267       write (iout,'(a)')
12268       write (iout,'(a)') '**************** dx/dtheta'
12269       write (iout,'(a)')
12270       do i=3,nres
12271       theti=theta(i)
12272         theta(i)=theta(i)+aincr
12273         do j=i-1,nres-1
12274           do k=1,3
12275             temp(k,j)=dc(k,nres+j)
12276           enddo
12277         enddo
12278         call chainbuild
12279         do j=i-1,nres-1
12280         ii = indmat(i-2,j)
12281 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12282         do k=1,3
12283           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12284           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12285                   (aincr*dabs(dxdv(k,ii))+aincr))
12286           enddo
12287           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12288               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12289           write(iout,'(a)')
12290         enddo
12291         write (iout,'(a)')
12292         theta(i)=theti
12293         call chainbuild
12294       enddo
12295       write (iout,'(a)') '***************** dx/dphi'
12296       write (iout,'(a)')
12297       do i=4,nres
12298         phi(i)=phi(i)+aincr
12299         do j=i-1,nres-1
12300           do k=1,3
12301             temp(k,j)=dc(k,nres+j)
12302           enddo
12303         enddo
12304         call chainbuild
12305         do j=i-1,nres-1
12306         ii = indmat(i-2,j)
12307 !         print *,'ii=',ii
12308         do k=1,3
12309           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12310             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12311                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12312           enddo
12313           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12314               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12315           write(iout,'(a)')
12316         enddo
12317         phi(i)=phi(i)-aincr
12318         call chainbuild
12319       enddo
12320       write (iout,'(a)') '****************** ddc/dtheta'
12321       do i=1,nres-2
12322         thet=theta(i+2)
12323         theta(i+2)=thet+aincr
12324         do j=i,nres
12325           do k=1,3
12326             temp(k,j)=dc(k,j)
12327           enddo
12328         enddo
12329         call chainbuild
12330         do j=i+1,nres-1
12331         ii = indmat(i,j)
12332 !         print *,'ii=',ii
12333         do k=1,3
12334           gg(k)=(dc(k,j)-temp(k,j))/aincr
12335           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12336                  (aincr*dabs(dcdv(k,ii))+aincr))
12337           enddo
12338           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12339                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12340         write (iout,'(a)')
12341         enddo
12342         do j=1,nres
12343           do k=1,3
12344             dc(k,j)=temp(k,j)
12345           enddo
12346         enddo
12347         theta(i+2)=thet
12348       enddo
12349       write (iout,'(a)') '******************* ddc/dphi'
12350       do i=1,nres-3
12351         phii=phi(i+3)
12352         phi(i+3)=phii+aincr
12353         do j=1,nres
12354           do k=1,3
12355             temp(k,j)=dc(k,j)
12356           enddo
12357         enddo
12358         call chainbuild
12359         do j=i+2,nres-1
12360         ii = indmat(i+1,j)
12361 !         print *,'ii=',ii
12362         do k=1,3
12363           gg(k)=(dc(k,j)-temp(k,j))/aincr
12364             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12365                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12366           enddo
12367           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12368                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12369         write (iout,'(a)')
12370         enddo
12371         do j=1,nres
12372           do k=1,3
12373             dc(k,j)=temp(k,j)
12374           enddo
12375         enddo
12376         phi(i+3)=phii
12377       enddo
12378       return
12379       end subroutine check_cartgrad
12380 !-----------------------------------------------------------------------------
12381       subroutine check_ecart
12382 ! Check the gradient of the energy in Cartesian coordinates.
12383 !     implicit real*8 (a-h,o-z)
12384 !     include 'DIMENSIONS'
12385 !     include 'COMMON.CHAIN'
12386 !     include 'COMMON.DERIV'
12387 !     include 'COMMON.IOUNITS'
12388 !     include 'COMMON.VAR'
12389 !     include 'COMMON.CONTACTS'
12390       use comm_srutu
12391 !el      integer :: icall
12392 !el      common /srutu/ icall
12393       real(kind=8),dimension(6) :: ggg
12394       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12395       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12396       real(kind=8),dimension(6,nres) :: grad_s
12397       real(kind=8),dimension(0:n_ene) :: energia,energia1
12398       integer :: uiparm(1)
12399       real(kind=8) :: urparm(1)
12400 !EL      external fdum
12401       integer :: nf,i,j,k
12402       real(kind=8) :: aincr,etot,etot1
12403       icg=1
12404       nf=0
12405       nfl=0
12406       call zerograd
12407       aincr=1.0D-5
12408       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12409       nf=0
12410       icall=0
12411       call geom_to_var(nvar,x)
12412       call etotal(energia)
12413       etot=energia(0)
12414 !el      call enerprint(energia)
12415       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12416       icall =1
12417       do i=1,nres
12418         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12419       enddo
12420       do i=1,nres
12421       do j=1,3
12422         grad_s(j,i)=gradc(j,i,icg)
12423         grad_s(j+3,i)=gradx(j,i,icg)
12424         enddo
12425       enddo
12426       call flush(iout)
12427       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12428       do i=1,nres
12429         do j=1,3
12430         xx(j)=c(j,i+nres)
12431         ddc(j)=dc(j,i)
12432         ddx(j)=dc(j,i+nres)
12433         enddo
12434       do j=1,3
12435         dc(j,i)=dc(j,i)+aincr
12436         do k=i+1,nres
12437           c(j,k)=c(j,k)+aincr
12438           c(j,k+nres)=c(j,k+nres)+aincr
12439           enddo
12440           call zerograd
12441           call etotal(energia1)
12442           etot1=energia1(0)
12443         ggg(j)=(etot1-etot)/aincr
12444         dc(j,i)=ddc(j)
12445         do k=i+1,nres
12446           c(j,k)=c(j,k)-aincr
12447           c(j,k+nres)=c(j,k+nres)-aincr
12448           enddo
12449         enddo
12450       do j=1,3
12451         c(j,i+nres)=c(j,i+nres)+aincr
12452         dc(j,i+nres)=dc(j,i+nres)+aincr
12453           call zerograd
12454           call etotal(energia1)
12455           etot1=energia1(0)
12456         ggg(j+3)=(etot1-etot)/aincr
12457         c(j,i+nres)=xx(j)
12458         dc(j,i+nres)=ddx(j)
12459         enddo
12460       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12461          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12462       enddo
12463       return
12464       end subroutine check_ecart
12465 #ifdef CARGRAD
12466 !-----------------------------------------------------------------------------
12467       subroutine check_ecartint
12468 ! Check the gradient of the energy in Cartesian coordinates.
12469       use io_base, only: intout
12470 !      implicit real*8 (a-h,o-z)
12471 !      include 'DIMENSIONS'
12472 !      include 'COMMON.CONTROL'
12473 !      include 'COMMON.CHAIN'
12474 !      include 'COMMON.DERIV'
12475 !      include 'COMMON.IOUNITS'
12476 !      include 'COMMON.VAR'
12477 !      include 'COMMON.CONTACTS'
12478 !      include 'COMMON.MD'
12479 !      include 'COMMON.LOCAL'
12480 !      include 'COMMON.SPLITELE'
12481       use comm_srutu
12482 !el      integer :: icall
12483 !el      common /srutu/ icall
12484       real(kind=8),dimension(6) :: ggg,ggg1
12485       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12486       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12487       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12488       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12489       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12490       real(kind=8),dimension(0:n_ene) :: energia,energia1
12491       integer :: uiparm(1)
12492       real(kind=8) :: urparm(1)
12493 !EL      external fdum
12494       integer :: i,j,k,nf
12495       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12496                    etot21,etot22
12497       r_cut=2.0d0
12498       rlambd=0.3d0
12499       icg=1
12500       nf=0
12501       nfl=0
12502       call intout
12503 !      call intcartderiv
12504 !      call checkintcartgrad
12505       call zerograd
12506       aincr=1.0D-5
12507       write(iout,*) 'Calling CHECK_ECARTINT.'
12508       nf=0
12509       icall=0
12510       call geom_to_var(nvar,x)
12511       write (iout,*) "split_ene ",split_ene
12512       call flush(iout)
12513       if (.not.split_ene) then
12514         call zerograd
12515         call etotal(energia)
12516         etot=energia(0)
12517         call cartgrad
12518         icall =1
12519         do i=1,nres
12520           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12521         enddo
12522         do j=1,3
12523           grad_s(j,0)=gcart(j,0)
12524         enddo
12525         do i=1,nres
12526           do j=1,3
12527             grad_s(j,i)=gcart(j,i)
12528             grad_s(j+3,i)=gxcart(j,i)
12529         write(iout,*) "before movement analytical gradient"
12530         do i=1,nres
12531           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12532           (gxcart(j,i),j=1,3)
12533         enddo
12534
12535           enddo
12536         enddo
12537       else
12538 !- split gradient check
12539         call zerograd
12540         call etotal_long(energia)
12541 !el        call enerprint(energia)
12542         call cartgrad
12543         icall =1
12544         do i=1,nres
12545           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12546           (gxcart(j,i),j=1,3)
12547         enddo
12548         do j=1,3
12549           grad_s(j,0)=gcart(j,0)
12550         enddo
12551         do i=1,nres
12552           do j=1,3
12553             grad_s(j,i)=gcart(j,i)
12554             grad_s(j+3,i)=gxcart(j,i)
12555           enddo
12556         enddo
12557         call zerograd
12558         call etotal_short(energia)
12559         call enerprint(energia)
12560         call cartgrad
12561         icall =1
12562         do i=1,nres
12563           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12564           (gxcart(j,i),j=1,3)
12565         enddo
12566         do j=1,3
12567           grad_s1(j,0)=gcart(j,0)
12568         enddo
12569         do i=1,nres
12570           do j=1,3
12571             grad_s1(j,i)=gcart(j,i)
12572             grad_s1(j+3,i)=gxcart(j,i)
12573           enddo
12574         enddo
12575       endif
12576       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12577 !      do i=1,nres
12578       do i=nnt,nct
12579         do j=1,3
12580           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12581           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12582         ddc(j)=c(j,i)
12583         ddx(j)=c(j,i+nres)
12584           dcnorm_safe1(j)=dc_norm(j,i-1)
12585           dcnorm_safe2(j)=dc_norm(j,i)
12586           dxnorm_safe(j)=dc_norm(j,i+nres)
12587         enddo
12588       do j=1,3
12589         c(j,i)=ddc(j)+aincr
12590           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12591           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12592           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12593           dc(j,i)=c(j,i+1)-c(j,i)
12594           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12595           call int_from_cart1(.false.)
12596           if (.not.split_ene) then
12597            call zerograd
12598             call etotal(energia1)
12599             etot1=energia1(0)
12600             write (iout,*) "ij",i,j," etot1",etot1
12601           else
12602 !- split gradient
12603             call etotal_long(energia1)
12604             etot11=energia1(0)
12605             call etotal_short(energia1)
12606             etot12=energia1(0)
12607           endif
12608 !- end split gradient
12609 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12610         c(j,i)=ddc(j)-aincr
12611           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12612           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12613           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12614           dc(j,i)=c(j,i+1)-c(j,i)
12615           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12616           call int_from_cart1(.false.)
12617           if (.not.split_ene) then
12618             call zerograd
12619             call etotal(energia1)
12620             etot2=energia1(0)
12621             write (iout,*) "ij",i,j," etot2",etot2
12622           ggg(j)=(etot1-etot2)/(2*aincr)
12623           else
12624 !- split gradient
12625             call etotal_long(energia1)
12626             etot21=energia1(0)
12627           ggg(j)=(etot11-etot21)/(2*aincr)
12628             call etotal_short(energia1)
12629             etot22=energia1(0)
12630           ggg1(j)=(etot12-etot22)/(2*aincr)
12631 !- end split gradient
12632 !            write (iout,*) "etot21",etot21," etot22",etot22
12633           endif
12634 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12635         c(j,i)=ddc(j)
12636           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12637           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12638           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12639           dc(j,i)=c(j,i+1)-c(j,i)
12640           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12641           dc_norm(j,i-1)=dcnorm_safe1(j)
12642           dc_norm(j,i)=dcnorm_safe2(j)
12643           dc_norm(j,i+nres)=dxnorm_safe(j)
12644         enddo
12645       do j=1,3
12646         c(j,i+nres)=ddx(j)+aincr
12647           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12648           call int_from_cart1(.false.)
12649           if (.not.split_ene) then
12650             call zerograd
12651             call etotal(energia1)
12652             etot1=energia1(0)
12653           else
12654 !- split gradient
12655             call etotal_long(energia1)
12656             etot11=energia1(0)
12657             call etotal_short(energia1)
12658             etot12=energia1(0)
12659           endif
12660 !- end split gradient
12661         c(j,i+nres)=ddx(j)-aincr
12662           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12663           call int_from_cart1(.false.)
12664           if (.not.split_ene) then
12665            call zerograd
12666            call etotal(energia1)
12667             etot2=energia1(0)
12668           ggg(j+3)=(etot1-etot2)/(2*aincr)
12669           else
12670 !- split gradient
12671             call etotal_long(energia1)
12672             etot21=energia1(0)
12673           ggg(j+3)=(etot11-etot21)/(2*aincr)
12674             call etotal_short(energia1)
12675             etot22=energia1(0)
12676           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12677 !- end split gradient
12678           endif
12679 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12680         c(j,i+nres)=ddx(j)
12681           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12682           dc_norm(j,i+nres)=dxnorm_safe(j)
12683           call int_from_cart1(.false.)
12684         enddo
12685       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12686          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12687         if (split_ene) then
12688           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12689          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12690          k=1,6)
12691          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12692          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12693          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12694         endif
12695       enddo
12696       return
12697       end subroutine check_ecartint
12698 #else
12699 !-----------------------------------------------------------------------------
12700       subroutine check_ecartint
12701 ! Check the gradient of the energy in Cartesian coordinates.
12702       use io_base, only: intout
12703 !      implicit real*8 (a-h,o-z)
12704 !      include 'DIMENSIONS'
12705 !      include 'COMMON.CONTROL'
12706 !      include 'COMMON.CHAIN'
12707 !      include 'COMMON.DERIV'
12708 !      include 'COMMON.IOUNITS'
12709 !      include 'COMMON.VAR'
12710 !      include 'COMMON.CONTACTS'
12711 !      include 'COMMON.MD'
12712 !      include 'COMMON.LOCAL'
12713 !      include 'COMMON.SPLITELE'
12714       use comm_srutu
12715 !el      integer :: icall
12716 !el      common /srutu/ icall
12717       real(kind=8),dimension(6) :: ggg,ggg1
12718       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12719       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12720       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12721       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12722       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12723       real(kind=8),dimension(0:n_ene) :: energia,energia1
12724       integer :: uiparm(1)
12725       real(kind=8) :: urparm(1)
12726 !EL      external fdum
12727       integer :: i,j,k,nf
12728       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12729                    etot21,etot22
12730       r_cut=2.0d0
12731       rlambd=0.3d0
12732       icg=1
12733       nf=0
12734       nfl=0
12735       call intout
12736 !      call intcartderiv
12737 !      call checkintcartgrad
12738       call zerograd
12739       aincr=1.0D-6
12740       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12741       nf=0
12742       icall=0
12743       call geom_to_var(nvar,x)
12744       if (.not.split_ene) then
12745         call etotal(energia)
12746         etot=energia(0)
12747 !el        call enerprint(energia)
12748         call cartgrad
12749         icall =1
12750         do i=1,nres
12751           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12752         enddo
12753         do j=1,3
12754           grad_s(j,0)=gcart(j,0)
12755         enddo
12756         do i=1,nres
12757           do j=1,3
12758             grad_s(j,i)=gcart(j,i)
12759             grad_s(j+3,i)=gxcart(j,i)
12760           enddo
12761         enddo
12762         write(iout,*) "before movement analytical gradient"
12763         do i=1,nres
12764           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12765           (gxcart(j,i),j=1,3)
12766         enddo
12767
12768       else
12769 !- split gradient check
12770         call zerograd
12771         call etotal_long(energia)
12772 !el        call enerprint(energia)
12773         call cartgrad
12774         icall =1
12775         do i=1,nres
12776           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12777           (gxcart(j,i),j=1,3)
12778         enddo
12779         do j=1,3
12780           grad_s(j,0)=gcart(j,0)
12781         enddo
12782         do i=1,nres
12783           do j=1,3
12784             grad_s(j,i)=gcart(j,i)
12785 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12786             grad_s(j+3,i)=gxcart(j,i)
12787           enddo
12788         enddo
12789         call zerograd
12790         call etotal_short(energia)
12791 !el        call enerprint(energia)
12792         call cartgrad
12793         icall =1
12794         do i=1,nres
12795           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12796           (gxcart(j,i),j=1,3)
12797         enddo
12798         do j=1,3
12799           grad_s1(j,0)=gcart(j,0)
12800         enddo
12801         do i=1,nres
12802           do j=1,3
12803             grad_s1(j,i)=gcart(j,i)
12804             grad_s1(j+3,i)=gxcart(j,i)
12805           enddo
12806         enddo
12807       endif
12808       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12809       do i=0,nres
12810         do j=1,3
12811         xx(j)=c(j,i+nres)
12812         ddc(j)=dc(j,i)
12813         ddx(j)=dc(j,i+nres)
12814           do k=1,3
12815             dcnorm_safe(k)=dc_norm(k,i)
12816             dxnorm_safe(k)=dc_norm(k,i+nres)
12817           enddo
12818         enddo
12819       do j=1,3
12820         dc(j,i)=ddc(j)+aincr
12821           call chainbuild_cart
12822 #ifdef MPI
12823 ! Broadcast the order to compute internal coordinates to the slaves.
12824 !          if (nfgtasks.gt.1)
12825 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12826 #endif
12827 !          call int_from_cart1(.false.)
12828           if (.not.split_ene) then
12829            call zerograd
12830             call etotal(energia1)
12831             etot1=energia1(0)
12832 !            call enerprint(energia1)
12833           else
12834 !- split gradient
12835             call etotal_long(energia1)
12836             etot11=energia1(0)
12837             call etotal_short(energia1)
12838             etot12=energia1(0)
12839 !            write (iout,*) "etot11",etot11," etot12",etot12
12840           endif
12841 !- end split gradient
12842 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12843         dc(j,i)=ddc(j)-aincr
12844           call chainbuild_cart
12845 !          call int_from_cart1(.false.)
12846           if (.not.split_ene) then
12847                   call zerograd
12848             call etotal(energia1)
12849             etot2=energia1(0)
12850           ggg(j)=(etot1-etot2)/(2*aincr)
12851           else
12852 !- split gradient
12853             call etotal_long(energia1)
12854             etot21=energia1(0)
12855           ggg(j)=(etot11-etot21)/(2*aincr)
12856             call etotal_short(energia1)
12857             etot22=energia1(0)
12858           ggg1(j)=(etot12-etot22)/(2*aincr)
12859 !- end split gradient
12860 !            write (iout,*) "etot21",etot21," etot22",etot22
12861           endif
12862 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12863         dc(j,i)=ddc(j)
12864           call chainbuild_cart
12865         enddo
12866       do j=1,3
12867         dc(j,i+nres)=ddx(j)+aincr
12868           call chainbuild_cart
12869 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12870 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12871 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12872 !          write (iout,*) "dxnormnorm",dsqrt(
12873 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12874 !          write (iout,*) "dxnormnormsafe",dsqrt(
12875 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12876 !          write (iout,*)
12877           if (.not.split_ene) then
12878             call zerograd
12879             call etotal(energia1)
12880             etot1=energia1(0)
12881           else
12882 !- split gradient
12883             call etotal_long(energia1)
12884             etot11=energia1(0)
12885             call etotal_short(energia1)
12886             etot12=energia1(0)
12887           endif
12888 !- end split gradient
12889 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12890         dc(j,i+nres)=ddx(j)-aincr
12891           call chainbuild_cart
12892 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12893 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12894 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12895 !          write (iout,*)
12896 !          write (iout,*) "dxnormnorm",dsqrt(
12897 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12898 !          write (iout,*) "dxnormnormsafe",dsqrt(
12899 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12900           if (.not.split_ene) then
12901             call zerograd
12902             call etotal(energia1)
12903             etot2=energia1(0)
12904           ggg(j+3)=(etot1-etot2)/(2*aincr)
12905           else
12906 !- split gradient
12907             call etotal_long(energia1)
12908             etot21=energia1(0)
12909           ggg(j+3)=(etot11-etot21)/(2*aincr)
12910             call etotal_short(energia1)
12911             etot22=energia1(0)
12912           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12913 !- end split gradient
12914           endif
12915 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12916         dc(j,i+nres)=ddx(j)
12917           call chainbuild_cart
12918         enddo
12919       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12920          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12921         if (split_ene) then
12922           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12923          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12924          k=1,6)
12925          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12926          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12927          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12928         endif
12929       enddo
12930       return
12931       end subroutine check_ecartint
12932 #endif
12933 !-----------------------------------------------------------------------------
12934       subroutine check_eint
12935 ! Check the gradient of energy in internal coordinates.
12936 !      implicit real*8 (a-h,o-z)
12937 !      include 'DIMENSIONS'
12938 !      include 'COMMON.CHAIN'
12939 !      include 'COMMON.DERIV'
12940 !      include 'COMMON.IOUNITS'
12941 !      include 'COMMON.VAR'
12942 !      include 'COMMON.GEO'
12943       use comm_srutu
12944 !el      integer :: icall
12945 !el      common /srutu/ icall
12946       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12947       integer :: uiparm(1)
12948       real(kind=8) :: urparm(1)
12949       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12950       character(len=6) :: key
12951 !EL      external fdum
12952       integer :: i,ii,nf
12953       real(kind=8) :: xi,aincr,etot,etot1,etot2
12954       call zerograd
12955       aincr=1.0D-7
12956       print '(a)','Calling CHECK_INT.'
12957       nf=0
12958       nfl=0
12959       icg=1
12960       call geom_to_var(nvar,x)
12961       call var_to_geom(nvar,x)
12962       call chainbuild
12963       icall=1
12964 !      print *,'ICG=',ICG
12965       call etotal(energia)
12966       etot = energia(0)
12967 !el      call enerprint(energia)
12968 !      print *,'ICG=',ICG
12969 #ifdef MPL
12970       if (MyID.ne.BossID) then
12971         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12972         nf=x(nvar+1)
12973         nfl=x(nvar+2)
12974         icg=x(nvar+3)
12975       endif
12976 #endif
12977       nf=1
12978       nfl=3
12979 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12980       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12981 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12982       icall=1
12983       do i=1,nvar
12984         xi=x(i)
12985         x(i)=xi-0.5D0*aincr
12986         call var_to_geom(nvar,x)
12987         call chainbuild
12988         call etotal(energia1)
12989         etot1=energia1(0)
12990         x(i)=xi+0.5D0*aincr
12991         call var_to_geom(nvar,x)
12992         call chainbuild
12993         call etotal(energia2)
12994         etot2=energia2(0)
12995         gg(i)=(etot2-etot1)/aincr
12996         write (iout,*) i,etot1,etot2
12997         x(i)=xi
12998       enddo
12999       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13000           '     RelDiff*100% '
13001       do i=1,nvar
13002         if (i.le.nphi) then
13003           ii=i
13004           key = ' phi'
13005         else if (i.le.nphi+ntheta) then
13006           ii=i-nphi
13007           key=' theta'
13008         else if (i.le.nphi+ntheta+nside) then
13009            ii=i-(nphi+ntheta)
13010            key=' alpha'
13011         else
13012            ii=i-(nphi+ntheta+nside)
13013            key=' omega'
13014         endif
13015         write (iout,'(i3,a,i3,3(1pd16.6))') &
13016        i,key,ii,gg(i),gana(i),&
13017        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13018       enddo
13019       return
13020       end subroutine check_eint
13021 !-----------------------------------------------------------------------------
13022 ! econstr_local.F
13023 !-----------------------------------------------------------------------------
13024       subroutine Econstr_back
13025 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13026 !      implicit real*8 (a-h,o-z)
13027 !      include 'DIMENSIONS'
13028 !      include 'COMMON.CONTROL'
13029 !      include 'COMMON.VAR'
13030 !      include 'COMMON.MD'
13031       use MD_data
13032 !#ifndef LANG0
13033 !      include 'COMMON.LANGEVIN'
13034 !#else
13035 !      include 'COMMON.LANGEVIN.lang0'
13036 !#endif
13037 !      include 'COMMON.CHAIN'
13038 !      include 'COMMON.DERIV'
13039 !      include 'COMMON.GEO'
13040 !      include 'COMMON.LOCAL'
13041 !      include 'COMMON.INTERACT'
13042 !      include 'COMMON.IOUNITS'
13043 !      include 'COMMON.NAMES'
13044 !      include 'COMMON.TIME1'
13045       integer :: i,j,ii,k
13046       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13047
13048       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13049       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13050       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13051
13052       Uconst_back=0.0d0
13053       do i=1,nres
13054         dutheta(i)=0.0d0
13055         dugamma(i)=0.0d0
13056         do j=1,3
13057           duscdiff(j,i)=0.0d0
13058           duscdiffx(j,i)=0.0d0
13059         enddo
13060       enddo
13061       do i=1,nfrag_back
13062         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13063 !
13064 ! Deviations from theta angles
13065 !
13066         utheta_i=0.0d0
13067         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13068           dtheta_i=theta(j)-thetaref(j)
13069           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13070           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13071         enddo
13072         utheta(i)=utheta_i/(ii-1)
13073 !
13074 ! Deviations from gamma angles
13075 !
13076         ugamma_i=0.0d0
13077         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13078           dgamma_i=pinorm(phi(j)-phiref(j))
13079 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13080           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13081           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13082 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13083         enddo
13084         ugamma(i)=ugamma_i/(ii-2)
13085 !
13086 ! Deviations from local SC geometry
13087 !
13088         uscdiff(i)=0.0d0
13089         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13090           dxx=xxtab(j)-xxref(j)
13091           dyy=yytab(j)-yyref(j)
13092           dzz=zztab(j)-zzref(j)
13093           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13094           do k=1,3
13095             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13096              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13097              (ii-1)
13098             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13099              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13100              (ii-1)
13101             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13102            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13103             /(ii-1)
13104           enddo
13105 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13106 !     &      xxref(j),yyref(j),zzref(j)
13107         enddo
13108         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13109 !        write (iout,*) i," uscdiff",uscdiff(i)
13110 !
13111 ! Put together deviations from local geometry
13112 !
13113         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13114           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13115 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13116 !     &   " uconst_back",uconst_back
13117         utheta(i)=dsqrt(utheta(i))
13118         ugamma(i)=dsqrt(ugamma(i))
13119         uscdiff(i)=dsqrt(uscdiff(i))
13120       enddo
13121       return
13122       end subroutine Econstr_back
13123 !-----------------------------------------------------------------------------
13124 ! energy_p_new-sep_barrier.F
13125 !-----------------------------------------------------------------------------
13126       real(kind=8) function sscale(r)
13127 !      include "COMMON.SPLITELE"
13128       real(kind=8) :: r,gamm
13129       if(r.lt.r_cut-rlamb) then
13130         sscale=1.0d0
13131       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13132         gamm=(r-(r_cut-rlamb))/rlamb
13133         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13134       else
13135         sscale=0d0
13136       endif
13137       return
13138       end function sscale
13139       real(kind=8) function sscale_grad(r)
13140 !      include "COMMON.SPLITELE"
13141       real(kind=8) :: r,gamm
13142       if(r.lt.r_cut-rlamb) then
13143         sscale_grad=0.0d0
13144       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13145         gamm=(r-(r_cut-rlamb))/rlamb
13146         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13147       else
13148         sscale_grad=0d0
13149       endif
13150       return
13151       end function sscale_grad
13152
13153 !!!!!!!!!! PBCSCALE
13154       real(kind=8) function sscale_ele(r)
13155 !      include "COMMON.SPLITELE"
13156       real(kind=8) :: r,gamm
13157       if(r.lt.r_cut_ele-rlamb_ele) then
13158         sscale_ele=1.0d0
13159       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13160         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13161         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13162       else
13163         sscale_ele=0d0
13164       endif
13165       return
13166       end function sscale_ele
13167
13168       real(kind=8)  function sscagrad_ele(r)
13169       real(kind=8) :: r,gamm
13170 !      include "COMMON.SPLITELE"
13171       if(r.lt.r_cut_ele-rlamb_ele) then
13172         sscagrad_ele=0.0d0
13173       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13174         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13175         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13176       else
13177         sscagrad_ele=0.0d0
13178       endif
13179       return
13180       end function sscagrad_ele
13181       real(kind=8) function sscalelip(r)
13182       real(kind=8) r,gamm
13183         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13184       return
13185       end function sscalelip
13186 !C-----------------------------------------------------------------------
13187       real(kind=8) function sscagradlip(r)
13188       real(kind=8) r,gamm
13189         sscagradlip=r*(6.0d0*r-6.0d0)
13190       return
13191       end function sscagradlip
13192
13193 !!!!!!!!!!!!!!!
13194 !-----------------------------------------------------------------------------
13195       subroutine elj_long(evdw)
13196 !
13197 ! This subroutine calculates the interaction energy of nonbonded side chains
13198 ! assuming the LJ potential of interaction.
13199 !
13200 !      implicit real*8 (a-h,o-z)
13201 !      include 'DIMENSIONS'
13202 !      include 'COMMON.GEO'
13203 !      include 'COMMON.VAR'
13204 !      include 'COMMON.LOCAL'
13205 !      include 'COMMON.CHAIN'
13206 !      include 'COMMON.DERIV'
13207 !      include 'COMMON.INTERACT'
13208 !      include 'COMMON.TORSION'
13209 !      include 'COMMON.SBRIDGE'
13210 !      include 'COMMON.NAMES'
13211 !      include 'COMMON.IOUNITS'
13212 !      include 'COMMON.CONTACTS'
13213       real(kind=8),parameter :: accur=1.0d-10
13214       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13215 !el local variables
13216       integer :: i,iint,j,k,itypi,itypi1,itypj
13217       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13218       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13219                       sslipj,ssgradlipj,aa,bb
13220 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13221       evdw=0.0D0
13222       do i=iatsc_s,iatsc_e
13223         itypi=itype(i,1)
13224         if (itypi.eq.ntyp1) cycle
13225         itypi1=itype(i+1,1)
13226         xi=c(1,nres+i)
13227         yi=c(2,nres+i)
13228         zi=c(3,nres+i)
13229         call to_box(xi,yi,zi)
13230         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13231 !
13232 ! Calculate SC interaction energy.
13233 !
13234         do iint=1,nint_gr(i)
13235 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13236 !d   &                  'iend=',iend(i,iint)
13237           do j=istart(i,iint),iend(i,iint)
13238             itypj=itype(j,1)
13239             if (itypj.eq.ntyp1) cycle
13240             xj=c(1,nres+j)-xi
13241             yj=c(2,nres+j)-yi
13242             zj=c(3,nres+j)-zi
13243             call to_box(xj,yj,zj)
13244             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13245             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13246              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13247             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13248              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13249             xj=boxshift(xj-xi,boxxsize)
13250             yj=boxshift(yj-yi,boxysize)
13251             zj=boxshift(zj-zi,boxzsize)
13252             rij=xj*xj+yj*yj+zj*zj
13253             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13254             if (sss.lt.1.0d0) then
13255               rrij=1.0D0/rij
13256               eps0ij=eps(itypi,itypj)
13257               fac=rrij**expon2
13258               e1=fac*fac*aa_aq(itypi,itypj)
13259               e2=fac*bb_aq(itypi,itypj)
13260               evdwij=e1+e2
13261               evdw=evdw+(1.0d0-sss)*evdwij
13262 !
13263 ! Calculate the components of the gradient in DC and X
13264 !
13265               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13266               gg(1)=xj*fac
13267               gg(2)=yj*fac
13268               gg(3)=zj*fac
13269               do k=1,3
13270                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13271                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13272                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13273                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13274               enddo
13275             endif
13276           enddo      ! j
13277         enddo        ! iint
13278       enddo          ! i
13279       do i=1,nct
13280         do j=1,3
13281           gvdwc(j,i)=expon*gvdwc(j,i)
13282           gvdwx(j,i)=expon*gvdwx(j,i)
13283         enddo
13284       enddo
13285 !******************************************************************************
13286 !
13287 !                              N O T E !!!
13288 !
13289 ! To save time, the factor of EXPON has been extracted from ALL components
13290 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13291 ! use!
13292 !
13293 !******************************************************************************
13294       return
13295       end subroutine elj_long
13296 !-----------------------------------------------------------------------------
13297       subroutine elj_short(evdw)
13298 !
13299 ! This subroutine calculates the interaction energy of nonbonded side chains
13300 ! assuming the LJ potential of interaction.
13301 !
13302 !      implicit real*8 (a-h,o-z)
13303 !      include 'DIMENSIONS'
13304 !      include 'COMMON.GEO'
13305 !      include 'COMMON.VAR'
13306 !      include 'COMMON.LOCAL'
13307 !      include 'COMMON.CHAIN'
13308 !      include 'COMMON.DERIV'
13309 !      include 'COMMON.INTERACT'
13310 !      include 'COMMON.TORSION'
13311 !      include 'COMMON.SBRIDGE'
13312 !      include 'COMMON.NAMES'
13313 !      include 'COMMON.IOUNITS'
13314 !      include 'COMMON.CONTACTS'
13315       real(kind=8),parameter :: accur=1.0d-10
13316       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13317 !el local variables
13318       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13319       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13320       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13321                       sslipj,ssgradlipj
13322 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13323       evdw=0.0D0
13324       do i=iatsc_s,iatsc_e
13325         itypi=itype(i,1)
13326         if (itypi.eq.ntyp1) cycle
13327         itypi1=itype(i+1,1)
13328         xi=c(1,nres+i)
13329         yi=c(2,nres+i)
13330         zi=c(3,nres+i)
13331         call to_box(xi,yi,zi)
13332         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13333 ! Change 12/1/95
13334         num_conti=0
13335 !
13336 ! Calculate SC interaction energy.
13337 !
13338         do iint=1,nint_gr(i)
13339 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13340 !d   &                  'iend=',iend(i,iint)
13341           do j=istart(i,iint),iend(i,iint)
13342             itypj=itype(j,1)
13343             if (itypj.eq.ntyp1) cycle
13344             xj=c(1,nres+j)-xi
13345             yj=c(2,nres+j)-yi
13346             zj=c(3,nres+j)-zi
13347 ! Change 12/1/95 to calculate four-body interactions
13348             rij=xj*xj+yj*yj+zj*zj
13349             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13350             if (sss.gt.0.0d0) then
13351               rrij=1.0D0/rij
13352               eps0ij=eps(itypi,itypj)
13353               fac=rrij**expon2
13354               e1=fac*fac*aa_aq(itypi,itypj)
13355               e2=fac*bb_aq(itypi,itypj)
13356               evdwij=e1+e2
13357               evdw=evdw+sss*evdwij
13358 !
13359 ! Calculate the components of the gradient in DC and X
13360 !
13361               fac=-rrij*(e1+evdwij)*sss
13362               gg(1)=xj*fac
13363               gg(2)=yj*fac
13364               gg(3)=zj*fac
13365               do k=1,3
13366                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13367                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13368                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13369                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13370               enddo
13371             endif
13372           enddo      ! j
13373         enddo        ! iint
13374       enddo          ! i
13375       do i=1,nct
13376         do j=1,3
13377           gvdwc(j,i)=expon*gvdwc(j,i)
13378           gvdwx(j,i)=expon*gvdwx(j,i)
13379         enddo
13380       enddo
13381 !******************************************************************************
13382 !
13383 !                              N O T E !!!
13384 !
13385 ! To save time, the factor of EXPON has been extracted from ALL components
13386 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13387 ! use!
13388 !
13389 !******************************************************************************
13390       return
13391       end subroutine elj_short
13392 !-----------------------------------------------------------------------------
13393       subroutine eljk_long(evdw)
13394 !
13395 ! This subroutine calculates the interaction energy of nonbonded side chains
13396 ! assuming the LJK potential of interaction.
13397 !
13398 !      implicit real*8 (a-h,o-z)
13399 !      include 'DIMENSIONS'
13400 !      include 'COMMON.GEO'
13401 !      include 'COMMON.VAR'
13402 !      include 'COMMON.LOCAL'
13403 !      include 'COMMON.CHAIN'
13404 !      include 'COMMON.DERIV'
13405 !      include 'COMMON.INTERACT'
13406 !      include 'COMMON.IOUNITS'
13407 !      include 'COMMON.NAMES'
13408       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13409       logical :: scheck
13410 !el local variables
13411       integer :: i,iint,j,k,itypi,itypi1,itypj
13412       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13413                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13414 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13415       evdw=0.0D0
13416       do i=iatsc_s,iatsc_e
13417         itypi=itype(i,1)
13418         if (itypi.eq.ntyp1) cycle
13419         itypi1=itype(i+1,1)
13420         xi=c(1,nres+i)
13421         yi=c(2,nres+i)
13422         zi=c(3,nres+i)
13423           call to_box(xi,yi,zi)
13424
13425 !
13426 ! Calculate SC interaction energy.
13427 !
13428         do iint=1,nint_gr(i)
13429           do j=istart(i,iint),iend(i,iint)
13430             itypj=itype(j,1)
13431             if (itypj.eq.ntyp1) cycle
13432             xj=c(1,nres+j)-xi
13433             yj=c(2,nres+j)-yi
13434             zj=c(3,nres+j)-zi
13435           call to_box(xj,yj,zj)
13436       xj=boxshift(xj-xi,boxxsize)
13437       yj=boxshift(yj-yi,boxysize)
13438       zj=boxshift(zj-zi,boxzsize)
13439
13440             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13441             fac_augm=rrij**expon
13442             e_augm=augm(itypi,itypj)*fac_augm
13443             r_inv_ij=dsqrt(rrij)
13444             rij=1.0D0/r_inv_ij
13445             sss=sscale(rij/sigma(itypi,itypj))
13446             if (sss.lt.1.0d0) then
13447               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13448               fac=r_shift_inv**expon
13449               e1=fac*fac*aa_aq(itypi,itypj)
13450               e2=fac*bb_aq(itypi,itypj)
13451               evdwij=e_augm+e1+e2
13452 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13453 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13454 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13455 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13456 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13457 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13458 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13459               evdw=evdw+(1.0d0-sss)*evdwij
13460 !
13461 ! Calculate the components of the gradient in DC and X
13462 !
13463               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13464               fac=fac*(1.0d0-sss)
13465               gg(1)=xj*fac
13466               gg(2)=yj*fac
13467               gg(3)=zj*fac
13468               do k=1,3
13469                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13470                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13471                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13472                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13473               enddo
13474             endif
13475           enddo      ! j
13476         enddo        ! iint
13477       enddo          ! i
13478       do i=1,nct
13479         do j=1,3
13480           gvdwc(j,i)=expon*gvdwc(j,i)
13481           gvdwx(j,i)=expon*gvdwx(j,i)
13482         enddo
13483       enddo
13484       return
13485       end subroutine eljk_long
13486 !-----------------------------------------------------------------------------
13487       subroutine eljk_short(evdw)
13488 !
13489 ! This subroutine calculates the interaction energy of nonbonded side chains
13490 ! assuming the LJK potential of interaction.
13491 !
13492 !      implicit real*8 (a-h,o-z)
13493 !      include 'DIMENSIONS'
13494 !      include 'COMMON.GEO'
13495 !      include 'COMMON.VAR'
13496 !      include 'COMMON.LOCAL'
13497 !      include 'COMMON.CHAIN'
13498 !      include 'COMMON.DERIV'
13499 !      include 'COMMON.INTERACT'
13500 !      include 'COMMON.IOUNITS'
13501 !      include 'COMMON.NAMES'
13502       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13503       logical :: scheck
13504 !el local variables
13505       integer :: i,iint,j,k,itypi,itypi1,itypj
13506       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13507                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
13508                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
13509 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13510       evdw=0.0D0
13511       do i=iatsc_s,iatsc_e
13512         itypi=itype(i,1)
13513         if (itypi.eq.ntyp1) cycle
13514         itypi1=itype(i+1,1)
13515         xi=c(1,nres+i)
13516         yi=c(2,nres+i)
13517         zi=c(3,nres+i)
13518         call to_box(xi,yi,zi)
13519         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13520 !
13521 ! Calculate SC interaction energy.
13522 !
13523         do iint=1,nint_gr(i)
13524           do j=istart(i,iint),iend(i,iint)
13525             itypj=itype(j,1)
13526             if (itypj.eq.ntyp1) cycle
13527             xj=c(1,nres+j)-xi
13528             yj=c(2,nres+j)-yi
13529             zj=c(3,nres+j)-zi
13530             call to_box(xj,yj,zj)
13531             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13532             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13533              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13534             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13535              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13536             xj=boxshift(xj-xi,boxxsize)
13537             yj=boxshift(yj-yi,boxysize)
13538             zj=boxshift(zj-zi,boxzsize)
13539             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13540             fac_augm=rrij**expon
13541             e_augm=augm(itypi,itypj)*fac_augm
13542             r_inv_ij=dsqrt(rrij)
13543             rij=1.0D0/r_inv_ij
13544             sss=sscale(rij/sigma(itypi,itypj))
13545             if (sss.gt.0.0d0) then
13546               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13547               fac=r_shift_inv**expon
13548               e1=fac*fac*aa_aq(itypi,itypj)
13549               e2=fac*bb_aq(itypi,itypj)
13550               evdwij=e_augm+e1+e2
13551 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13552 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13553 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13554 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13555 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13556 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13557 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13558               evdw=evdw+sss*evdwij
13559 !
13560 ! Calculate the components of the gradient in DC and X
13561 !
13562               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13563               fac=fac*sss
13564               gg(1)=xj*fac
13565               gg(2)=yj*fac
13566               gg(3)=zj*fac
13567               do k=1,3
13568                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13569                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13570                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13571                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13572               enddo
13573             endif
13574           enddo      ! j
13575         enddo        ! iint
13576       enddo          ! i
13577       do i=1,nct
13578         do j=1,3
13579           gvdwc(j,i)=expon*gvdwc(j,i)
13580           gvdwx(j,i)=expon*gvdwx(j,i)
13581         enddo
13582       enddo
13583       return
13584       end subroutine eljk_short
13585 !-----------------------------------------------------------------------------
13586        subroutine ebp_long(evdw)
13587 ! This subroutine calculates the interaction energy of nonbonded side chains
13588 ! assuming the Berne-Pechukas potential of interaction.
13589 !
13590        use calc_data
13591 !      implicit real*8 (a-h,o-z)
13592 !      include 'DIMENSIONS'
13593 !      include 'COMMON.GEO'
13594 !      include 'COMMON.VAR'
13595 !      include 'COMMON.LOCAL'
13596 !      include 'COMMON.CHAIN'
13597 !      include 'COMMON.DERIV'
13598 !      include 'COMMON.NAMES'
13599 !      include 'COMMON.INTERACT'
13600 !      include 'COMMON.IOUNITS'
13601 !      include 'COMMON.CALC'
13602        use comm_srutu
13603 !el      integer :: icall
13604 !el      common /srutu/ icall
13605 !     double precision rrsave(maxdim)
13606         logical :: lprn
13607 !el local variables
13608         integer :: iint,itypi,itypi1,itypj
13609         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
13610                         sslipj,ssgradlipj,aa,bb
13611         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13612         evdw=0.0D0
13613 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13614         evdw=0.0D0
13615 !     if (icall.eq.0) then
13616 !       lprn=.true.
13617 !     else
13618       lprn=.false.
13619 !     endif
13620 !el      ind=0
13621       do i=iatsc_s,iatsc_e
13622       itypi=itype(i,1)
13623       if (itypi.eq.ntyp1) cycle
13624       itypi1=itype(i+1,1)
13625       xi=c(1,nres+i)
13626       yi=c(2,nres+i)
13627       zi=c(3,nres+i)
13628         call to_box(xi,yi,zi)
13629         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13630       dxi=dc_norm(1,nres+i)
13631       dyi=dc_norm(2,nres+i)
13632       dzi=dc_norm(3,nres+i)
13633 !        dsci_inv=dsc_inv(itypi)
13634       dsci_inv=vbld_inv(i+nres)
13635 !
13636 ! Calculate SC interaction energy.
13637 !
13638       do iint=1,nint_gr(i)
13639       do j=istart(i,iint),iend(i,iint)
13640 !el            ind=ind+1
13641       itypj=itype(j,1)
13642       if (itypj.eq.ntyp1) cycle
13643 !            dscj_inv=dsc_inv(itypj)
13644       dscj_inv=vbld_inv(j+nres)
13645 chi1=chi(itypi,itypj)
13646 chi2=chi(itypj,itypi)
13647 chi12=chi1*chi2
13648 chip1=chip(itypi)
13649       alf1=alp(itypi)
13650       alf2=alp(itypj)
13651       alf12=0.5D0*(alf1+alf2)
13652         xj=c(1,nres+j)-xi
13653         yj=c(2,nres+j)-yi
13654         zj=c(3,nres+j)-zi
13655             call to_box(xj,yj,zj)
13656             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13657             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13658              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13659             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13660              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13661             xj=boxshift(xj-xi,boxxsize)
13662             yj=boxshift(yj-yi,boxysize)
13663             zj=boxshift(zj-zi,boxzsize)
13664         dxj=dc_norm(1,nres+j)
13665         dyj=dc_norm(2,nres+j)
13666         dzj=dc_norm(3,nres+j)
13667         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13668         rij=dsqrt(rrij)
13669       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13670
13671         if (sss.lt.1.0d0) then
13672
13673         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13674         call sc_angular
13675         ! Calculate whole angle-dependent part of epsilon and contributions
13676         ! to its derivatives
13677         fac=(rrij*sigsq)**expon2
13678         e1=fac*fac*aa_aq(itypi,itypj)
13679         e2=fac*bb_aq(itypi,itypj)
13680       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13681         eps2der=evdwij*eps3rt
13682         eps3der=evdwij*eps2rt
13683         evdwij=evdwij*eps2rt*eps3rt
13684       evdw=evdw+evdwij*(1.0d0-sss)
13685         if (lprn) then
13686         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13687       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13688         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13689         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13690         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13691         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13692         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13693         !d     &          evdwij
13694         endif
13695         ! Calculate gradient components.
13696         e1=e1*eps1*eps2rt**2*eps3rt**2
13697       fac=-expon*(e1+evdwij)
13698         sigder=fac/sigsq
13699         fac=rrij*fac
13700         ! Calculate radial part of the gradient
13701         gg(1)=xj*fac
13702         gg(2)=yj*fac
13703         gg(3)=zj*fac
13704         ! Calculate the angular part of the gradient and sum add the contributions
13705         ! to the appropriate components of the Cartesian gradient.
13706       call sc_grad_scale(1.0d0-sss)
13707         endif
13708         enddo      ! j
13709         enddo        ! iint
13710         enddo          ! i
13711         !     stop
13712         return
13713         end subroutine ebp_long
13714         !-----------------------------------------------------------------------------
13715       subroutine ebp_short(evdw)
13716         !
13717         ! This subroutine calculates the interaction energy of nonbonded side chains
13718         ! assuming the Berne-Pechukas potential of interaction.
13719         !
13720         use calc_data
13721 !      implicit real*8 (a-h,o-z)
13722         !      include 'DIMENSIONS'
13723         !      include 'COMMON.GEO'
13724         !      include 'COMMON.VAR'
13725         !      include 'COMMON.LOCAL'
13726         !      include 'COMMON.CHAIN'
13727         !      include 'COMMON.DERIV'
13728         !      include 'COMMON.NAMES'
13729         !      include 'COMMON.INTERACT'
13730         !      include 'COMMON.IOUNITS'
13731         !      include 'COMMON.CALC'
13732         use comm_srutu
13733         !el      integer :: icall
13734         !el      common /srutu/ icall
13735 !     double precision rrsave(maxdim)
13736         logical :: lprn
13737         !el local variables
13738         integer :: iint,itypi,itypi1,itypj
13739         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13740         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
13741         sslipi,ssgradlipi,sslipj,ssgradlipj
13742         evdw=0.0D0
13743         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13744         evdw=0.0D0
13745         !     if (icall.eq.0) then
13746         !       lprn=.true.
13747         !     else
13748         lprn=.false.
13749         !     endif
13750         !el      ind=0
13751         do i=iatsc_s,iatsc_e
13752       itypi=itype(i,1)
13753         if (itypi.eq.ntyp1) cycle
13754         itypi1=itype(i+1,1)
13755         xi=c(1,nres+i)
13756         yi=c(2,nres+i)
13757         zi=c(3,nres+i)
13758         call to_box(xi,yi,zi)
13759       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13760
13761         dxi=dc_norm(1,nres+i)
13762         dyi=dc_norm(2,nres+i)
13763         dzi=dc_norm(3,nres+i)
13764         !        dsci_inv=dsc_inv(itypi)
13765       dsci_inv=vbld_inv(i+nres)
13766         !
13767         ! Calculate SC interaction energy.
13768         !
13769         do iint=1,nint_gr(i)
13770       do j=istart(i,iint),iend(i,iint)
13771         !el            ind=ind+1
13772       itypj=itype(j,1)
13773         if (itypj.eq.ntyp1) cycle
13774         !            dscj_inv=dsc_inv(itypj)
13775         dscj_inv=vbld_inv(j+nres)
13776         chi1=chi(itypi,itypj)
13777       chi2=chi(itypj,itypi)
13778         chi12=chi1*chi2
13779         chip1=chip(itypi)
13780       chip2=chip(itypj)
13781         chip12=chip1*chip2
13782         alf1=alp(itypi)
13783         alf2=alp(itypj)
13784       alf12=0.5D0*(alf1+alf2)
13785         xj=c(1,nres+j)-xi
13786         yj=c(2,nres+j)-yi
13787         zj=c(3,nres+j)-zi
13788         call to_box(xj,yj,zj)
13789       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13790         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13791         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13792         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13793              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13794             xj=boxshift(xj-xi,boxxsize)
13795             yj=boxshift(yj-yi,boxysize)
13796             zj=boxshift(zj-zi,boxzsize)
13797             dxj=dc_norm(1,nres+j)
13798             dyj=dc_norm(2,nres+j)
13799             dzj=dc_norm(3,nres+j)
13800             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13801             rij=dsqrt(rrij)
13802             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13803
13804             if (sss.gt.0.0d0) then
13805
13806 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13807               call sc_angular
13808 ! Calculate whole angle-dependent part of epsilon and contributions
13809 ! to its derivatives
13810               fac=(rrij*sigsq)**expon2
13811               e1=fac*fac*aa_aq(itypi,itypj)
13812               e2=fac*bb_aq(itypi,itypj)
13813               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13814               eps2der=evdwij*eps3rt
13815               eps3der=evdwij*eps2rt
13816               evdwij=evdwij*eps2rt*eps3rt
13817               evdw=evdw+evdwij*sss
13818               if (lprn) then
13819               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13820               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13821 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13822 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13823 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13824 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13825 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13826 !d     &          evdwij
13827               endif
13828 ! Calculate gradient components.
13829               e1=e1*eps1*eps2rt**2*eps3rt**2
13830               fac=-expon*(e1+evdwij)
13831               sigder=fac/sigsq
13832               fac=rrij*fac
13833 ! Calculate radial part of the gradient
13834               gg(1)=xj*fac
13835               gg(2)=yj*fac
13836               gg(3)=zj*fac
13837 ! Calculate the angular part of the gradient and sum add the contributions
13838 ! to the appropriate components of the Cartesian gradient.
13839               call sc_grad_scale(sss)
13840             endif
13841           enddo      ! j
13842         enddo        ! iint
13843       enddo          ! i
13844 !     stop
13845       return
13846       end subroutine ebp_short
13847 !-----------------------------------------------------------------------------
13848       subroutine egb_long(evdw)
13849 !
13850 ! This subroutine calculates the interaction energy of nonbonded side chains
13851 ! assuming the Gay-Berne potential of interaction.
13852 !
13853       use calc_data
13854 !      implicit real*8 (a-h,o-z)
13855 !      include 'DIMENSIONS'
13856 !      include 'COMMON.GEO'
13857 !      include 'COMMON.VAR'
13858 !      include 'COMMON.LOCAL'
13859 !      include 'COMMON.CHAIN'
13860 !      include 'COMMON.DERIV'
13861 !      include 'COMMON.NAMES'
13862 !      include 'COMMON.INTERACT'
13863 !      include 'COMMON.IOUNITS'
13864 !      include 'COMMON.CALC'
13865 !      include 'COMMON.CONTROL'
13866       logical :: lprn
13867 !el local variables
13868       integer :: iint,itypi,itypi1,itypj,subchap
13869       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13870       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13871       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13872                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13873                     ssgradlipi,ssgradlipj
13874
13875
13876       evdw=0.0D0
13877 !cccc      energy_dec=.false.
13878 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13879       evdw=0.0D0
13880       lprn=.false.
13881 !     if (icall.eq.0) lprn=.false.
13882 !el      ind=0
13883       do i=iatsc_s,iatsc_e
13884         itypi=itype(i,1)
13885         if (itypi.eq.ntyp1) cycle
13886         itypi1=itype(i+1,1)
13887         xi=c(1,nres+i)
13888         yi=c(2,nres+i)
13889         zi=c(3,nres+i)
13890         call to_box(xi,yi,zi)
13891         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13892         dxi=dc_norm(1,nres+i)
13893         dyi=dc_norm(2,nres+i)
13894         dzi=dc_norm(3,nres+i)
13895 !        dsci_inv=dsc_inv(itypi)
13896         dsci_inv=vbld_inv(i+nres)
13897 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13898 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13899 !
13900 ! Calculate SC interaction energy.
13901 !
13902         do iint=1,nint_gr(i)
13903           do j=istart(i,iint),iend(i,iint)
13904             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13905 !              call dyn_ssbond_ene(i,j,evdwij)
13906 !              evdw=evdw+evdwij
13907 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13908 !                              'evdw',i,j,evdwij,' ss'
13909 !              if (energy_dec) write (iout,*) &
13910 !                              'evdw',i,j,evdwij,' ss'
13911 !             do k=j+1,iend(i,iint)
13912 !C search over all next residues
13913 !              if (dyn_ss_mask(k)) then
13914 !C check if they are cysteins
13915 !C              write(iout,*) 'k=',k
13916
13917 !c              write(iout,*) "PRZED TRI", evdwij
13918 !               evdwij_przed_tri=evdwij
13919 !              call triple_ssbond_ene(i,j,k,evdwij)
13920 !c               if(evdwij_przed_tri.ne.evdwij) then
13921 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13922 !c               endif
13923
13924 !c              write(iout,*) "PO TRI", evdwij
13925 !C call the energy function that removes the artifical triple disulfide
13926 !C bond the soubroutine is located in ssMD.F
13927 !              evdw=evdw+evdwij
13928               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13929                             'evdw',i,j,evdwij,'tss'
13930 !              endif!dyn_ss_mask(k)
13931 !             enddo! k
13932
13933             ELSE
13934 !el            ind=ind+1
13935             itypj=itype(j,1)
13936             if (itypj.eq.ntyp1) cycle
13937 !            dscj_inv=dsc_inv(itypj)
13938             dscj_inv=vbld_inv(j+nres)
13939 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13940 !     &       1.0d0/vbld(j+nres)
13941 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13942             sig0ij=sigma(itypi,itypj)
13943             chi1=chi(itypi,itypj)
13944             chi2=chi(itypj,itypi)
13945             chi12=chi1*chi2
13946             chip1=chip(itypi)
13947             chip2=chip(itypj)
13948             chip12=chip1*chip2
13949             alf1=alp(itypi)
13950             alf2=alp(itypj)
13951             alf12=0.5D0*(alf1+alf2)
13952             xj=c(1,nres+j)
13953             yj=c(2,nres+j)
13954             zj=c(3,nres+j)
13955 ! Searching for nearest neighbour
13956             call to_box(xj,yj,zj)
13957             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13958             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13959              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13960             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13961              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13962             xj=boxshift(xj-xi,boxxsize)
13963             yj=boxshift(yj-yi,boxysize)
13964             zj=boxshift(zj-zi,boxzsize)
13965             dxj=dc_norm(1,nres+j)
13966             dyj=dc_norm(2,nres+j)
13967             dzj=dc_norm(3,nres+j)
13968             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13969             rij=dsqrt(rrij)
13970             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13971             sss_ele_cut=sscale_ele(1.0d0/(rij))
13972             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
13973             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13974             if (sss_ele_cut.le.0.0) cycle
13975             if (sss.lt.1.0d0) then
13976
13977 ! Calculate angle-dependent terms of energy and contributions to their
13978 ! derivatives.
13979               call sc_angular
13980               sigsq=1.0D0/sigsq
13981               sig=sig0ij*dsqrt(sigsq)
13982               rij_shift=1.0D0/rij-sig+sig0ij
13983 ! for diagnostics; uncomment
13984 !              rij_shift=1.2*sig0ij
13985 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13986               if (rij_shift.le.0.0D0) then
13987                 evdw=1.0D20
13988 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13989 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13990 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13991                 return
13992               endif
13993               sigder=-sig*sigsq
13994 !---------------------------------------------------------------
13995               rij_shift=1.0D0/rij_shift
13996               fac=rij_shift**expon
13997               e1=fac*fac*aa
13998               e2=fac*bb
13999               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14000               eps2der=evdwij*eps3rt
14001               eps3der=evdwij*eps2rt
14002 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14003 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14004               evdwij=evdwij*eps2rt*eps3rt
14005               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14006               if (lprn) then
14007               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14008               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14009               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14010                 restyp(itypi,1),i,restyp(itypj,1),j,&
14011                 epsi,sigm,chi1,chi2,chip1,chip2,&
14012                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14013                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14014                 evdwij
14015               endif
14016
14017               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14018                               'evdw',i,j,evdwij
14019 !              if (energy_dec) write (iout,*) &
14020 !                              'evdw',i,j,evdwij,"egb_long"
14021
14022 ! Calculate gradient components.
14023               e1=e1*eps1*eps2rt**2*eps3rt**2
14024               fac=-expon*(e1+evdwij)*rij_shift
14025               sigder=fac*sigder
14026               fac=rij*fac
14027               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14028               *rij-sss_grad/(1.0-sss)*rij  &
14029             /sigmaii(itypi,itypj))
14030 !              fac=0.0d0
14031 ! Calculate the radial part of the gradient
14032               gg(1)=xj*fac
14033               gg(2)=yj*fac
14034               gg(3)=zj*fac
14035 ! Calculate angular part of the gradient.
14036               call sc_grad_scale(1.0d0-sss)
14037             ENDIF    !mask_dyn_ss
14038             endif
14039           enddo      ! j
14040         enddo        ! iint
14041       enddo          ! i
14042 !      write (iout,*) "Number of loop steps in EGB:",ind
14043 !ccc      energy_dec=.false.
14044       return
14045       end subroutine egb_long
14046 !-----------------------------------------------------------------------------
14047       subroutine egb_short(evdw)
14048 !
14049 ! This subroutine calculates the interaction energy of nonbonded side chains
14050 ! assuming the Gay-Berne potential of interaction.
14051 !
14052       use calc_data
14053 !      implicit real*8 (a-h,o-z)
14054 !      include 'DIMENSIONS'
14055 !      include 'COMMON.GEO'
14056 !      include 'COMMON.VAR'
14057 !      include 'COMMON.LOCAL'
14058 !      include 'COMMON.CHAIN'
14059 !      include 'COMMON.DERIV'
14060 !      include 'COMMON.NAMES'
14061 !      include 'COMMON.INTERACT'
14062 !      include 'COMMON.IOUNITS'
14063 !      include 'COMMON.CALC'
14064 !      include 'COMMON.CONTROL'
14065       logical :: lprn
14066 !el local variables
14067       integer :: iint,itypi,itypi1,itypj,subchap
14068       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14069       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14070       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14071                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14072                     ssgradlipi,ssgradlipj
14073       evdw=0.0D0
14074 !cccc      energy_dec=.false.
14075 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14076       evdw=0.0D0
14077       lprn=.false.
14078 !     if (icall.eq.0) lprn=.false.
14079 !el      ind=0
14080       do i=iatsc_s,iatsc_e
14081         itypi=itype(i,1)
14082         if (itypi.eq.ntyp1) cycle
14083         itypi1=itype(i+1,1)
14084         xi=c(1,nres+i)
14085         yi=c(2,nres+i)
14086         zi=c(3,nres+i)
14087         call to_box(xi,yi,zi)
14088         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14089
14090         dxi=dc_norm(1,nres+i)
14091         dyi=dc_norm(2,nres+i)
14092         dzi=dc_norm(3,nres+i)
14093 !        dsci_inv=dsc_inv(itypi)
14094         dsci_inv=vbld_inv(i+nres)
14095
14096         dxi=dc_norm(1,nres+i)
14097         dyi=dc_norm(2,nres+i)
14098         dzi=dc_norm(3,nres+i)
14099 !        dsci_inv=dsc_inv(itypi)
14100         dsci_inv=vbld_inv(i+nres)
14101         do iint=1,nint_gr(i)
14102           do j=istart(i,iint),iend(i,iint)
14103             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14104               call dyn_ssbond_ene(i,j,evdwij)
14105               evdw=evdw+evdwij
14106               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14107                               'evdw',i,j,evdwij,' ss'
14108              do k=j+1,iend(i,iint)
14109 !C search over all next residues
14110               if (dyn_ss_mask(k)) then
14111 !C check if they are cysteins
14112 !C              write(iout,*) 'k=',k
14113
14114 !c              write(iout,*) "PRZED TRI", evdwij
14115 !               evdwij_przed_tri=evdwij
14116               call triple_ssbond_ene(i,j,k,evdwij)
14117 !c               if(evdwij_przed_tri.ne.evdwij) then
14118 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14119 !c               endif
14120
14121 !c              write(iout,*) "PO TRI", evdwij
14122 !C call the energy function that removes the artifical triple disulfide
14123 !C bond the soubroutine is located in ssMD.F
14124               evdw=evdw+evdwij
14125               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14126                             'evdw',i,j,evdwij,'tss'
14127               endif!dyn_ss_mask(k)
14128              enddo! k
14129             ELSE
14130
14131 !          typj=itype(j,1)
14132             if (itypj.eq.ntyp1) cycle
14133 !            dscj_inv=dsc_inv(itypj)
14134             dscj_inv=vbld_inv(j+nres)
14135             dscj_inv=dsc_inv(itypj)
14136 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14137 !     &       1.0d0/vbld(j+nres)
14138 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14139             sig0ij=sigma(itypi,itypj)
14140             chi1=chi(itypi,itypj)
14141             chi2=chi(itypj,itypi)
14142             chi12=chi1*chi2
14143             chip1=chip(itypi)
14144             chip2=chip(itypj)
14145             chip12=chip1*chip2
14146             alf1=alp(itypi)
14147             alf2=alp(itypj)
14148             alf12=0.5D0*(alf1+alf2)
14149 !            xj=c(1,nres+j)-xi
14150 !            yj=c(2,nres+j)-yi
14151 !            zj=c(3,nres+j)-zi
14152             xj=c(1,nres+j)
14153             yj=c(2,nres+j)
14154             zj=c(3,nres+j)
14155 ! Searching for nearest neighbour
14156             call to_box(xj,yj,zj)
14157             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14158             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14159              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14160             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14161              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14162             xj=boxshift(xj-xi,boxxsize)
14163             yj=boxshift(yj-yi,boxysize)
14164             zj=boxshift(zj-zi,boxzsize)
14165             dxj=dc_norm(1,nres+j)
14166             dyj=dc_norm(2,nres+j)
14167             dzj=dc_norm(3,nres+j)
14168             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14169             rij=dsqrt(rrij)
14170             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14171             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14172             sss_ele_cut=sscale_ele(1.0d0/(rij))
14173             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14174             if (sss_ele_cut.le.0.0) cycle
14175
14176             if (sss.gt.0.0d0) then
14177
14178 ! Calculate angle-dependent terms of energy and contributions to their
14179 ! derivatives.
14180               call sc_angular
14181               sigsq=1.0D0/sigsq
14182               sig=sig0ij*dsqrt(sigsq)
14183               rij_shift=1.0D0/rij-sig+sig0ij
14184 ! for diagnostics; uncomment
14185 !              rij_shift=1.2*sig0ij
14186 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14187               if (rij_shift.le.0.0D0) then
14188                 evdw=1.0D20
14189 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14190 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14191 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14192                 return
14193               endif
14194               sigder=-sig*sigsq
14195 !---------------------------------------------------------------
14196               rij_shift=1.0D0/rij_shift
14197               fac=rij_shift**expon
14198               e1=fac*fac*aa
14199               e2=fac*bb
14200               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14201               eps2der=evdwij*eps3rt
14202               eps3der=evdwij*eps2rt
14203 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14204 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14205               evdwij=evdwij*eps2rt*eps3rt
14206               evdw=evdw+evdwij*sss*sss_ele_cut
14207               if (lprn) then
14208               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14209               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14210               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14211                 restyp(itypi,1),i,restyp(itypj,1),j,&
14212                 epsi,sigm,chi1,chi2,chip1,chip2,&
14213                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14214                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14215                 evdwij
14216               endif
14217
14218               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14219                               'evdw',i,j,evdwij
14220 !              if (energy_dec) write (iout,*) &
14221 !                              'evdw',i,j,evdwij,"egb_short"
14222
14223 ! Calculate gradient components.
14224               e1=e1*eps1*eps2rt**2*eps3rt**2
14225               fac=-expon*(e1+evdwij)*rij_shift
14226               sigder=fac*sigder
14227               fac=rij*fac
14228               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14229             *rij+sss_grad/sss*rij  &
14230             /sigmaii(itypi,itypj))
14231
14232 !              fac=0.0d0
14233 ! Calculate the radial part of the gradient
14234               gg(1)=xj*fac
14235               gg(2)=yj*fac
14236               gg(3)=zj*fac
14237 ! Calculate angular part of the gradient.
14238               call sc_grad_scale(sss)
14239             endif
14240           ENDIF !mask_dyn_ss
14241           enddo      ! j
14242         enddo        ! iint
14243       enddo          ! i
14244 !      write (iout,*) "Number of loop steps in EGB:",ind
14245 !ccc      energy_dec=.false.
14246       return
14247       end subroutine egb_short
14248 !-----------------------------------------------------------------------------
14249       subroutine egbv_long(evdw)
14250 !
14251 ! This subroutine calculates the interaction energy of nonbonded side chains
14252 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14253 !
14254       use calc_data
14255 !      implicit real*8 (a-h,o-z)
14256 !      include 'DIMENSIONS'
14257 !      include 'COMMON.GEO'
14258 !      include 'COMMON.VAR'
14259 !      include 'COMMON.LOCAL'
14260 !      include 'COMMON.CHAIN'
14261 !      include 'COMMON.DERIV'
14262 !      include 'COMMON.NAMES'
14263 !      include 'COMMON.INTERACT'
14264 !      include 'COMMON.IOUNITS'
14265 !      include 'COMMON.CALC'
14266       use comm_srutu
14267 !el      integer :: icall
14268 !el      common /srutu/ icall
14269       logical :: lprn
14270 !el local variables
14271       integer :: iint,itypi,itypi1,itypj
14272       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14273                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14274       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14275       evdw=0.0D0
14276 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14277       evdw=0.0D0
14278       lprn=.false.
14279 !     if (icall.eq.0) lprn=.true.
14280 !el      ind=0
14281       do i=iatsc_s,iatsc_e
14282         itypi=itype(i,1)
14283         if (itypi.eq.ntyp1) cycle
14284         itypi1=itype(i+1,1)
14285         xi=c(1,nres+i)
14286         yi=c(2,nres+i)
14287         zi=c(3,nres+i)
14288         call to_box(xi,yi,zi)
14289         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14290         dxi=dc_norm(1,nres+i)
14291         dyi=dc_norm(2,nres+i)
14292         dzi=dc_norm(3,nres+i)
14293
14294 !        dsci_inv=dsc_inv(itypi)
14295         dsci_inv=vbld_inv(i+nres)
14296 !
14297 ! Calculate SC interaction energy.
14298 !
14299         do iint=1,nint_gr(i)
14300           do j=istart(i,iint),iend(i,iint)
14301 !el            ind=ind+1
14302             itypj=itype(j,1)
14303             if (itypj.eq.ntyp1) cycle
14304 !            dscj_inv=dsc_inv(itypj)
14305             dscj_inv=vbld_inv(j+nres)
14306             sig0ij=sigma(itypi,itypj)
14307             r0ij=r0(itypi,itypj)
14308             chi1=chi(itypi,itypj)
14309             chi2=chi(itypj,itypi)
14310             chi12=chi1*chi2
14311             chip1=chip(itypi)
14312             chip2=chip(itypj)
14313             chip12=chip1*chip2
14314             alf1=alp(itypi)
14315             alf2=alp(itypj)
14316             alf12=0.5D0*(alf1+alf2)
14317             xj=c(1,nres+j)-xi
14318             yj=c(2,nres+j)-yi
14319             zj=c(3,nres+j)-zi
14320             call to_box(xj,yj,zj)
14321             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14322             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14323             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14324             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14325             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14326             xj=boxshift(xj-xi,boxxsize)
14327             yj=boxshift(yj-yi,boxysize)
14328             zj=boxshift(zj-zi,boxzsize)
14329             dxj=dc_norm(1,nres+j)
14330             dyj=dc_norm(2,nres+j)
14331             dzj=dc_norm(3,nres+j)
14332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14333             rij=dsqrt(rrij)
14334
14335             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14336
14337             if (sss.lt.1.0d0) then
14338
14339 ! Calculate angle-dependent terms of energy and contributions to their
14340 ! derivatives.
14341               call sc_angular
14342               sigsq=1.0D0/sigsq
14343               sig=sig0ij*dsqrt(sigsq)
14344               rij_shift=1.0D0/rij-sig+r0ij
14345 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14346               if (rij_shift.le.0.0D0) then
14347                 evdw=1.0D20
14348                 return
14349               endif
14350               sigder=-sig*sigsq
14351 !---------------------------------------------------------------
14352               rij_shift=1.0D0/rij_shift
14353               fac=rij_shift**expon
14354               e1=fac*fac*aa_aq(itypi,itypj)
14355               e2=fac*bb_aq(itypi,itypj)
14356               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14357               eps2der=evdwij*eps3rt
14358               eps3der=evdwij*eps2rt
14359               fac_augm=rrij**expon
14360               e_augm=augm(itypi,itypj)*fac_augm
14361               evdwij=evdwij*eps2rt*eps3rt
14362               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14363               if (lprn) then
14364               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14365               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14366               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14367                 restyp(itypi,1),i,restyp(itypj,1),j,&
14368                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14369                 chi1,chi2,chip1,chip2,&
14370                 eps1,eps2rt**2,eps3rt**2,&
14371                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14372                 evdwij+e_augm
14373               endif
14374 ! Calculate gradient components.
14375               e1=e1*eps1*eps2rt**2*eps3rt**2
14376               fac=-expon*(e1+evdwij)*rij_shift
14377               sigder=fac*sigder
14378               fac=rij*fac-2*expon*rrij*e_augm
14379 ! Calculate the radial part of the gradient
14380               gg(1)=xj*fac
14381               gg(2)=yj*fac
14382               gg(3)=zj*fac
14383 ! Calculate angular part of the gradient.
14384               call sc_grad_scale(1.0d0-sss)
14385             endif
14386           enddo      ! j
14387         enddo        ! iint
14388       enddo          ! i
14389       end subroutine egbv_long
14390 !-----------------------------------------------------------------------------
14391       subroutine egbv_short(evdw)
14392 !
14393 ! This subroutine calculates the interaction energy of nonbonded side chains
14394 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14395 !
14396       use calc_data
14397 !      implicit real*8 (a-h,o-z)
14398 !      include 'DIMENSIONS'
14399 !      include 'COMMON.GEO'
14400 !      include 'COMMON.VAR'
14401 !      include 'COMMON.LOCAL'
14402 !      include 'COMMON.CHAIN'
14403 !      include 'COMMON.DERIV'
14404 !      include 'COMMON.NAMES'
14405 !      include 'COMMON.INTERACT'
14406 !      include 'COMMON.IOUNITS'
14407 !      include 'COMMON.CALC'
14408       use comm_srutu
14409 !el      integer :: icall
14410 !el      common /srutu/ icall
14411       logical :: lprn
14412 !el local variables
14413       integer :: iint,itypi,itypi1,itypj
14414       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
14415                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
14416       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14417       evdw=0.0D0
14418 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14419       evdw=0.0D0
14420       lprn=.false.
14421 !     if (icall.eq.0) lprn=.true.
14422 !el      ind=0
14423       do i=iatsc_s,iatsc_e
14424         itypi=itype(i,1)
14425         if (itypi.eq.ntyp1) cycle
14426         itypi1=itype(i+1,1)
14427         xi=c(1,nres+i)
14428         yi=c(2,nres+i)
14429         zi=c(3,nres+i)
14430         dxi=dc_norm(1,nres+i)
14431         dyi=dc_norm(2,nres+i)
14432         dzi=dc_norm(3,nres+i)
14433         call to_box(xi,yi,zi)
14434         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14435 !        dsci_inv=dsc_inv(itypi)
14436         dsci_inv=vbld_inv(i+nres)
14437 !
14438 ! Calculate SC interaction energy.
14439 !
14440         do iint=1,nint_gr(i)
14441           do j=istart(i,iint),iend(i,iint)
14442 !el            ind=ind+1
14443             itypj=itype(j,1)
14444             if (itypj.eq.ntyp1) cycle
14445 !            dscj_inv=dsc_inv(itypj)
14446             dscj_inv=vbld_inv(j+nres)
14447             sig0ij=sigma(itypi,itypj)
14448             r0ij=r0(itypi,itypj)
14449             chi1=chi(itypi,itypj)
14450             chi2=chi(itypj,itypi)
14451             chi12=chi1*chi2
14452             chip1=chip(itypi)
14453             chip2=chip(itypj)
14454             chip12=chip1*chip2
14455             alf1=alp(itypi)
14456             alf2=alp(itypj)
14457             alf12=0.5D0*(alf1+alf2)
14458             xj=c(1,nres+j)-xi
14459             yj=c(2,nres+j)-yi
14460             zj=c(3,nres+j)-zi
14461             call to_box(xj,yj,zj)
14462             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14463             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14464             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14465             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14466             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14467             xj=boxshift(xj-xi,boxxsize)
14468             yj=boxshift(yj-yi,boxysize)
14469             zj=boxshift(zj-zi,boxzsize)
14470             dxj=dc_norm(1,nres+j)
14471             dyj=dc_norm(2,nres+j)
14472             dzj=dc_norm(3,nres+j)
14473             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14474             rij=dsqrt(rrij)
14475
14476             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14477
14478             if (sss.gt.0.0d0) then
14479
14480 ! Calculate angle-dependent terms of energy and contributions to their
14481 ! derivatives.
14482               call sc_angular
14483               sigsq=1.0D0/sigsq
14484               sig=sig0ij*dsqrt(sigsq)
14485               rij_shift=1.0D0/rij-sig+r0ij
14486 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14487               if (rij_shift.le.0.0D0) then
14488                 evdw=1.0D20
14489                 return
14490               endif
14491               sigder=-sig*sigsq
14492 !---------------------------------------------------------------
14493               rij_shift=1.0D0/rij_shift
14494               fac=rij_shift**expon
14495               e1=fac*fac*aa_aq(itypi,itypj)
14496               e2=fac*bb_aq(itypi,itypj)
14497               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14498               eps2der=evdwij*eps3rt
14499               eps3der=evdwij*eps2rt
14500               fac_augm=rrij**expon
14501               e_augm=augm(itypi,itypj)*fac_augm
14502               evdwij=evdwij*eps2rt*eps3rt
14503               evdw=evdw+(evdwij+e_augm)*sss
14504               if (lprn) then
14505               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14506               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14507               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14508                 restyp(itypi,1),i,restyp(itypj,1),j,&
14509                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14510                 chi1,chi2,chip1,chip2,&
14511                 eps1,eps2rt**2,eps3rt**2,&
14512                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14513                 evdwij+e_augm
14514               endif
14515 ! Calculate gradient components.
14516               e1=e1*eps1*eps2rt**2*eps3rt**2
14517               fac=-expon*(e1+evdwij)*rij_shift
14518               sigder=fac*sigder
14519               fac=rij*fac-2*expon*rrij*e_augm
14520 ! Calculate the radial part of the gradient
14521               gg(1)=xj*fac
14522               gg(2)=yj*fac
14523               gg(3)=zj*fac
14524 ! Calculate angular part of the gradient.
14525               call sc_grad_scale(sss)
14526             endif
14527           enddo      ! j
14528         enddo        ! iint
14529       enddo          ! i
14530       end subroutine egbv_short
14531 !-----------------------------------------------------------------------------
14532       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14533 !
14534 ! This subroutine calculates the average interaction energy and its gradient
14535 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14536 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14537 ! The potential depends both on the distance of peptide-group centers and on
14538 ! the orientation of the CA-CA virtual bonds.
14539 !
14540 !      implicit real*8 (a-h,o-z)
14541
14542       use comm_locel
14543 #ifdef MPI
14544       include 'mpif.h'
14545 #endif
14546 !      include 'DIMENSIONS'
14547 !      include 'COMMON.CONTROL'
14548 !      include 'COMMON.SETUP'
14549 !      include 'COMMON.IOUNITS'
14550 !      include 'COMMON.GEO'
14551 !      include 'COMMON.VAR'
14552 !      include 'COMMON.LOCAL'
14553 !      include 'COMMON.CHAIN'
14554 !      include 'COMMON.DERIV'
14555 !      include 'COMMON.INTERACT'
14556 !      include 'COMMON.CONTACTS'
14557 !      include 'COMMON.TORSION'
14558 !      include 'COMMON.VECTORS'
14559 !      include 'COMMON.FFIELD'
14560 !      include 'COMMON.TIME1'
14561       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14562       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14563       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14564 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14565       real(kind=8),dimension(4) :: muij
14566 !el      integer :: num_conti,j1,j2
14567 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14568 !el                   dz_normi,xmedi,ymedi,zmedi
14569 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14570 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14571 !el          num_conti,j1,j2
14572 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14573 #ifdef MOMENT
14574       real(kind=8) :: scal_el=1.0d0
14575 #else
14576       real(kind=8) :: scal_el=0.5d0
14577 #endif
14578 ! 12/13/98
14579 ! 13-go grudnia roku pamietnego...
14580       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14581                                              0.0d0,1.0d0,0.0d0,&
14582                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14583 !el local variables
14584       integer :: i,j,k
14585       real(kind=8) :: fac
14586       real(kind=8) :: dxj,dyj,dzj
14587       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14588
14589 !      allocate(num_cont_hb(nres)) !(maxres)
14590 !d      write(iout,*) 'In EELEC'
14591 !d      do i=1,nloctyp
14592 !d        write(iout,*) 'Type',i
14593 !d        write(iout,*) 'B1',B1(:,i)
14594 !d        write(iout,*) 'B2',B2(:,i)
14595 !d        write(iout,*) 'CC',CC(:,:,i)
14596 !d        write(iout,*) 'DD',DD(:,:,i)
14597 !d        write(iout,*) 'EE',EE(:,:,i)
14598 !d      enddo
14599 !d      call check_vecgrad
14600 !d      stop
14601       if (icheckgrad.eq.1) then
14602         do i=1,nres-1
14603           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14604           do k=1,3
14605             dc_norm(k,i)=dc(k,i)*fac
14606           enddo
14607 !          write (iout,*) 'i',i,' fac',fac
14608         enddo
14609       endif
14610       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14611           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14612           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14613 !        call vec_and_deriv
14614 #ifdef TIMING
14615         time01=MPI_Wtime()
14616 #endif
14617 !        print *, "before set matrices"
14618         call set_matrices
14619 !        print *,"after set martices"
14620 #ifdef TIMING
14621         time_mat=time_mat+MPI_Wtime()-time01
14622 #endif
14623       endif
14624 !d      do i=1,nres-1
14625 !d        write (iout,*) 'i=',i
14626 !d        do k=1,3
14627 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14628 !d        enddo
14629 !d        do k=1,3
14630 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14631 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14632 !d        enddo
14633 !d      enddo
14634       t_eelecij=0.0d0
14635       ees=0.0D0
14636       evdw1=0.0D0
14637       eel_loc=0.0d0
14638       eello_turn3=0.0d0
14639       eello_turn4=0.0d0
14640 !el      ind=0
14641       do i=1,nres
14642         num_cont_hb(i)=0
14643       enddo
14644 !d      print '(a)','Enter EELEC'
14645 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14646 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14647 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14648       do i=1,nres
14649         gel_loc_loc(i)=0.0d0
14650         gcorr_loc(i)=0.0d0
14651       enddo
14652 !
14653 !
14654 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14655 !
14656 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14657 !
14658       do i=iturn3_start,iturn3_end
14659         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14660         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14661         dxi=dc(1,i)
14662         dyi=dc(2,i)
14663         dzi=dc(3,i)
14664         dx_normi=dc_norm(1,i)
14665         dy_normi=dc_norm(2,i)
14666         dz_normi=dc_norm(3,i)
14667         xmedi=c(1,i)+0.5d0*dxi
14668         ymedi=c(2,i)+0.5d0*dyi
14669         zmedi=c(3,i)+0.5d0*dzi
14670         call to_box(xmedi,ymedi,zmedi)
14671         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14672         num_conti=0
14673         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14674         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14675         num_cont_hb(i)=num_conti
14676       enddo
14677       do i=iturn4_start,iturn4_end
14678         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14679           .or. itype(i+3,1).eq.ntyp1 &
14680           .or. itype(i+4,1).eq.ntyp1) cycle
14681         dxi=dc(1,i)
14682         dyi=dc(2,i)
14683         dzi=dc(3,i)
14684         dx_normi=dc_norm(1,i)
14685         dy_normi=dc_norm(2,i)
14686         dz_normi=dc_norm(3,i)
14687         xmedi=c(1,i)+0.5d0*dxi
14688         ymedi=c(2,i)+0.5d0*dyi
14689         zmedi=c(3,i)+0.5d0*dzi
14690
14691         call to_box(xmedi,ymedi,zmedi)
14692         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14693
14694         num_conti=num_cont_hb(i)
14695         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14696         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14697           call eturn4(i,eello_turn4)
14698         num_cont_hb(i)=num_conti
14699       enddo   ! i
14700 !
14701 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14702 !
14703       do i=iatel_s,iatel_e
14704         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14705         dxi=dc(1,i)
14706         dyi=dc(2,i)
14707         dzi=dc(3,i)
14708         dx_normi=dc_norm(1,i)
14709         dy_normi=dc_norm(2,i)
14710         dz_normi=dc_norm(3,i)
14711         xmedi=c(1,i)+0.5d0*dxi
14712         ymedi=c(2,i)+0.5d0*dyi
14713         zmedi=c(3,i)+0.5d0*dzi
14714         call to_box(xmedi,ymedi,zmedi)
14715         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14716 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14717         num_conti=num_cont_hb(i)
14718         do j=ielstart(i),ielend(i)
14719           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14720           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14721         enddo ! j
14722         num_cont_hb(i)=num_conti
14723       enddo   ! i
14724 !      write (iout,*) "Number of loop steps in EELEC:",ind
14725 !d      do i=1,nres
14726 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14727 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14728 !d      enddo
14729 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14730 !cc      eel_loc=eel_loc+eello_turn3
14731 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14732       return
14733       end subroutine eelec_scale
14734 !-----------------------------------------------------------------------------
14735       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14736 !      implicit real*8 (a-h,o-z)
14737
14738       use comm_locel
14739 !      include 'DIMENSIONS'
14740 #ifdef MPI
14741       include "mpif.h"
14742 #endif
14743 !      include 'COMMON.CONTROL'
14744 !      include 'COMMON.IOUNITS'
14745 !      include 'COMMON.GEO'
14746 !      include 'COMMON.VAR'
14747 !      include 'COMMON.LOCAL'
14748 !      include 'COMMON.CHAIN'
14749 !      include 'COMMON.DERIV'
14750 !      include 'COMMON.INTERACT'
14751 !      include 'COMMON.CONTACTS'
14752 !      include 'COMMON.TORSION'
14753 !      include 'COMMON.VECTORS'
14754 !      include 'COMMON.FFIELD'
14755 !      include 'COMMON.TIME1'
14756       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14757       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14758       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14759 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14760       real(kind=8),dimension(4) :: muij
14761       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14762                     dist_temp, dist_init,sss_grad
14763       integer xshift,yshift,zshift
14764
14765 !el      integer :: num_conti,j1,j2
14766 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14767 !el                   dz_normi,xmedi,ymedi,zmedi
14768 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14769 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14770 !el          num_conti,j1,j2
14771 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14772 #ifdef MOMENT
14773       real(kind=8) :: scal_el=1.0d0
14774 #else
14775       real(kind=8) :: scal_el=0.5d0
14776 #endif
14777 ! 12/13/98
14778 ! 13-go grudnia roku pamietnego...
14779       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14780                                              0.0d0,1.0d0,0.0d0,&
14781                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14782 !el local variables
14783       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14784       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14785       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14786       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14787       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14788       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14789       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14790                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14791                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14792                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14793                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14794                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
14795 !      integer :: maxconts
14796 !      maxconts = nres/4
14797 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14798 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14799 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14800 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14801 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14802 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14803 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14804 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14805 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14806 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14807 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14808 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14809 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14810
14811 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14812 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14813
14814 #ifdef MPI
14815           time00=MPI_Wtime()
14816 #endif
14817 !d      write (iout,*) "eelecij",i,j
14818 !el          ind=ind+1
14819           iteli=itel(i)
14820           itelj=itel(j)
14821           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14822           aaa=app(iteli,itelj)
14823           bbb=bpp(iteli,itelj)
14824           ael6i=ael6(iteli,itelj)
14825           ael3i=ael3(iteli,itelj)
14826           dxj=dc(1,j)
14827           dyj=dc(2,j)
14828           dzj=dc(3,j)
14829           dx_normj=dc_norm(1,j)
14830           dy_normj=dc_norm(2,j)
14831           dz_normj=dc_norm(3,j)
14832 !          xj=c(1,j)+0.5D0*dxj-xmedi
14833 !          yj=c(2,j)+0.5D0*dyj-ymedi
14834 !          zj=c(3,j)+0.5D0*dzj-zmedi
14835           xj=c(1,j)+0.5D0*dxj
14836           yj=c(2,j)+0.5D0*dyj
14837           zj=c(3,j)+0.5D0*dzj
14838           call to_box(xj,yj,zj)
14839           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14840           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
14841           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
14842           xj=boxshift(xj-xmedi,boxxsize)
14843           yj=boxshift(yj-ymedi,boxysize)
14844           zj=boxshift(zj-zmedi,boxzsize)
14845           rij=xj*xj+yj*yj+zj*zj
14846           rrmij=1.0D0/rij
14847           rij=dsqrt(rij)
14848           rmij=1.0D0/rij
14849 ! For extracting the short-range part of Evdwpp
14850           sss=sscale(rij/rpp(iteli,itelj))
14851             sss_ele_cut=sscale_ele(rij)
14852             sss_ele_grad=sscagrad_ele(rij)
14853             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14854 !             sss_ele_cut=1.0d0
14855 !             sss_ele_grad=0.0d0
14856             if (sss_ele_cut.le.0.0) go to 128
14857
14858           r3ij=rrmij*rmij
14859           r6ij=r3ij*r3ij
14860           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14861           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14862           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14863           fac=cosa-3.0D0*cosb*cosg
14864           ev1=aaa*r6ij*r6ij
14865 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14866           if (j.eq.i+2) ev1=scal_el*ev1
14867           ev2=bbb*r6ij
14868           fac3=ael6i*r6ij
14869           fac4=ael3i*r3ij
14870           evdwij=ev1+ev2
14871           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14872           el2=fac4*fac
14873           eesij=el1+el2
14874 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14875           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14876           ees=ees+eesij*sss_ele_cut
14877           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14878 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14879 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14880 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14881 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14882
14883           if (energy_dec) then
14884               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14885               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14886           endif
14887
14888 !
14889 ! Calculate contributions to the Cartesian gradient.
14890 !
14891 #ifdef SPLITELE
14892           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14893           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14894           fac1=fac
14895           erij(1)=xj*rmij
14896           erij(2)=yj*rmij
14897           erij(3)=zj*rmij
14898 !
14899 ! Radial derivatives. First process both termini of the fragment (i,j)
14900 !
14901           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14902           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14903           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14904 !          do k=1,3
14905 !            ghalf=0.5D0*ggg(k)
14906 !            gelc(k,i)=gelc(k,i)+ghalf
14907 !            gelc(k,j)=gelc(k,j)+ghalf
14908 !          enddo
14909 ! 9/28/08 AL Gradient compotents will be summed only at the end
14910           do k=1,3
14911             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14912             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14913           enddo
14914 !
14915 ! Loop over residues i+1 thru j-1.
14916 !
14917 !grad          do k=i+1,j-1
14918 !grad            do l=1,3
14919 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14920 !grad            enddo
14921 !grad          enddo
14922           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14923           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14924           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14925           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14926           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14927           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14928 !          do k=1,3
14929 !            ghalf=0.5D0*ggg(k)
14930 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14931 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14932 !          enddo
14933 ! 9/28/08 AL Gradient compotents will be summed only at the end
14934           do k=1,3
14935             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14936             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14937           enddo
14938 !
14939 ! Loop over residues i+1 thru j-1.
14940 !
14941 !grad          do k=i+1,j-1
14942 !grad            do l=1,3
14943 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14944 !grad            enddo
14945 !grad          enddo
14946 #else
14947           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14948           facel=(el1+eesij)*sss_ele_cut
14949           fac1=fac
14950           fac=-3*rrmij*(facvdw+facvdw+facel)
14951           erij(1)=xj*rmij
14952           erij(2)=yj*rmij
14953           erij(3)=zj*rmij
14954 !
14955 ! Radial derivatives. First process both termini of the fragment (i,j)
14956 !
14957           ggg(1)=fac*xj
14958           ggg(2)=fac*yj
14959           ggg(3)=fac*zj
14960 !          do k=1,3
14961 !            ghalf=0.5D0*ggg(k)
14962 !            gelc(k,i)=gelc(k,i)+ghalf
14963 !            gelc(k,j)=gelc(k,j)+ghalf
14964 !          enddo
14965 ! 9/28/08 AL Gradient compotents will be summed only at the end
14966           do k=1,3
14967             gelc_long(k,j)=gelc(k,j)+ggg(k)
14968             gelc_long(k,i)=gelc(k,i)-ggg(k)
14969           enddo
14970 !
14971 ! Loop over residues i+1 thru j-1.
14972 !
14973 !grad          do k=i+1,j-1
14974 !grad            do l=1,3
14975 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14976 !grad            enddo
14977 !grad          enddo
14978 ! 9/28/08 AL Gradient compotents will be summed only at the end
14979           ggg(1)=facvdw*xj
14980           ggg(2)=facvdw*yj
14981           ggg(3)=facvdw*zj
14982           do k=1,3
14983             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14984             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14985           enddo
14986 #endif
14987 !
14988 ! Angular part
14989 !
14990           ecosa=2.0D0*fac3*fac1+fac4
14991           fac4=-3.0D0*fac4
14992           fac3=-6.0D0*fac3
14993           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14994           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14995           do k=1,3
14996             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14997             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14998           enddo
14999 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15000 !d   &          (dcosg(k),k=1,3)
15001           do k=1,3
15002             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15003           enddo
15004 !          do k=1,3
15005 !            ghalf=0.5D0*ggg(k)
15006 !            gelc(k,i)=gelc(k,i)+ghalf
15007 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15008 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15009 !            gelc(k,j)=gelc(k,j)+ghalf
15010 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15011 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15012 !          enddo
15013 !grad          do k=i+1,j-1
15014 !grad            do l=1,3
15015 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15016 !grad            enddo
15017 !grad          enddo
15018           do k=1,3
15019             gelc(k,i)=gelc(k,i) &
15020                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15021                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15022                      *sss_ele_cut
15023             gelc(k,j)=gelc(k,j) &
15024                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15025                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15026                      *sss_ele_cut
15027             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15028             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15029           enddo
15030           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15031               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15032               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15033 !
15034 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15035 !   energy of a peptide unit is assumed in the form of a second-order
15036 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15037 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15038 !   are computed for EVERY pair of non-contiguous peptide groups.
15039 !
15040           if (j.lt.nres-1) then
15041             j1=j+1
15042             j2=j-1
15043           else
15044             j1=j-1
15045             j2=j-2
15046           endif
15047           kkk=0
15048           do k=1,2
15049             do l=1,2
15050               kkk=kkk+1
15051               muij(kkk)=mu(k,i)*mu(l,j)
15052             enddo
15053           enddo
15054 !d         write (iout,*) 'EELEC: i',i,' j',j
15055 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15056 !d          write(iout,*) 'muij',muij
15057           ury=scalar(uy(1,i),erij)
15058           urz=scalar(uz(1,i),erij)
15059           vry=scalar(uy(1,j),erij)
15060           vrz=scalar(uz(1,j),erij)
15061           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15062           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15063           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15064           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15065           fac=dsqrt(-ael6i)*r3ij
15066           a22=a22*fac
15067           a23=a23*fac
15068           a32=a32*fac
15069           a33=a33*fac
15070 !d          write (iout,'(4i5,4f10.5)')
15071 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15072 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15073 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15074 !d     &      uy(:,j),uz(:,j)
15075 !d          write (iout,'(4f10.5)')
15076 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15077 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15078 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15079 !d           write (iout,'(9f10.5/)')
15080 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15081 ! Derivatives of the elements of A in virtual-bond vectors
15082           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15083           do k=1,3
15084             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15085             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15086             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15087             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15088             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15089             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15090             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15091             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15092             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15093             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15094             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15095             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15096           enddo
15097 ! Compute radial contributions to the gradient
15098           facr=-3.0d0*rrmij
15099           a22der=a22*facr
15100           a23der=a23*facr
15101           a32der=a32*facr
15102           a33der=a33*facr
15103           agg(1,1)=a22der*xj
15104           agg(2,1)=a22der*yj
15105           agg(3,1)=a22der*zj
15106           agg(1,2)=a23der*xj
15107           agg(2,2)=a23der*yj
15108           agg(3,2)=a23der*zj
15109           agg(1,3)=a32der*xj
15110           agg(2,3)=a32der*yj
15111           agg(3,3)=a32der*zj
15112           agg(1,4)=a33der*xj
15113           agg(2,4)=a33der*yj
15114           agg(3,4)=a33der*zj
15115 ! Add the contributions coming from er
15116           fac3=-3.0d0*fac
15117           do k=1,3
15118             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15119             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15120             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15121             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15122           enddo
15123           do k=1,3
15124 ! Derivatives in DC(i)
15125 !grad            ghalf1=0.5d0*agg(k,1)
15126 !grad            ghalf2=0.5d0*agg(k,2)
15127 !grad            ghalf3=0.5d0*agg(k,3)
15128 !grad            ghalf4=0.5d0*agg(k,4)
15129             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15130             -3.0d0*uryg(k,2)*vry)!+ghalf1
15131             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15132             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15133             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15134             -3.0d0*urzg(k,2)*vry)!+ghalf3
15135             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15136             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15137 ! Derivatives in DC(i+1)
15138             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15139             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15140             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15141             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15142             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15143             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15144             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15145             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15146 ! Derivatives in DC(j)
15147             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15148             -3.0d0*vryg(k,2)*ury)!+ghalf1
15149             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15150             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15151             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15152             -3.0d0*vryg(k,2)*urz)!+ghalf3
15153             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15154             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15155 ! Derivatives in DC(j+1) or DC(nres-1)
15156             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15157             -3.0d0*vryg(k,3)*ury)
15158             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15159             -3.0d0*vrzg(k,3)*ury)
15160             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15161             -3.0d0*vryg(k,3)*urz)
15162             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15163             -3.0d0*vrzg(k,3)*urz)
15164 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15165 !grad              do l=1,4
15166 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15167 !grad              enddo
15168 !grad            endif
15169           enddo
15170           acipa(1,1)=a22
15171           acipa(1,2)=a23
15172           acipa(2,1)=a32
15173           acipa(2,2)=a33
15174           a22=-a22
15175           a23=-a23
15176           do l=1,2
15177             do k=1,3
15178               agg(k,l)=-agg(k,l)
15179               aggi(k,l)=-aggi(k,l)
15180               aggi1(k,l)=-aggi1(k,l)
15181               aggj(k,l)=-aggj(k,l)
15182               aggj1(k,l)=-aggj1(k,l)
15183             enddo
15184           enddo
15185           if (j.lt.nres-1) then
15186             a22=-a22
15187             a32=-a32
15188             do l=1,3,2
15189               do k=1,3
15190                 agg(k,l)=-agg(k,l)
15191                 aggi(k,l)=-aggi(k,l)
15192                 aggi1(k,l)=-aggi1(k,l)
15193                 aggj(k,l)=-aggj(k,l)
15194                 aggj1(k,l)=-aggj1(k,l)
15195               enddo
15196             enddo
15197           else
15198             a22=-a22
15199             a23=-a23
15200             a32=-a32
15201             a33=-a33
15202             do l=1,4
15203               do k=1,3
15204                 agg(k,l)=-agg(k,l)
15205                 aggi(k,l)=-aggi(k,l)
15206                 aggi1(k,l)=-aggi1(k,l)
15207                 aggj(k,l)=-aggj(k,l)
15208                 aggj1(k,l)=-aggj1(k,l)
15209               enddo
15210             enddo
15211           endif
15212           ENDIF ! WCORR
15213           IF (wel_loc.gt.0.0d0) THEN
15214 ! Contribution to the local-electrostatic energy coming from the i-j pair
15215           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15216            +a33*muij(4)
15217 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15218 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15219           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15220                   'eelloc',i,j,eel_loc_ij
15221 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15222
15223           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15224 ! Partial derivatives in virtual-bond dihedral angles gamma
15225           if (i.gt.1) &
15226           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15227                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15228                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15229                  *sss_ele_cut
15230           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15231                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15232                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15233                  *sss_ele_cut
15234            xtemp(1)=xj
15235            xtemp(2)=yj
15236            xtemp(3)=zj
15237
15238 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15239           do l=1,3
15240             ggg(l)=(agg(l,1)*muij(1)+ &
15241                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15242             *sss_ele_cut &
15243              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15244
15245             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15246             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15247 !grad            ghalf=0.5d0*ggg(l)
15248 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15249 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15250           enddo
15251 !grad          do k=i+1,j2
15252 !grad            do l=1,3
15253 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15254 !grad            enddo
15255 !grad          enddo
15256 ! Remaining derivatives of eello
15257           do l=1,3
15258             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15259                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15260             *sss_ele_cut
15261
15262             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15263                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15264             *sss_ele_cut
15265
15266             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15267                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15268             *sss_ele_cut
15269
15270             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15271                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15272             *sss_ele_cut
15273
15274           enddo
15275           ENDIF
15276 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15277 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15278           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15279              .and. num_conti.le.maxconts) then
15280 !            write (iout,*) i,j," entered corr"
15281 !
15282 ! Calculate the contact function. The ith column of the array JCONT will
15283 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15284 ! greater than I). The arrays FACONT and GACONT will contain the values of
15285 ! the contact function and its derivative.
15286 !           r0ij=1.02D0*rpp(iteli,itelj)
15287 !           r0ij=1.11D0*rpp(iteli,itelj)
15288             r0ij=2.20D0*rpp(iteli,itelj)
15289 !           r0ij=1.55D0*rpp(iteli,itelj)
15290             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15291 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15292             if (fcont.gt.0.0D0) then
15293               num_conti=num_conti+1
15294               if (num_conti.gt.maxconts) then
15295 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15296                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15297                                ' will skip next contacts for this conf.',num_conti
15298               else
15299                 jcont_hb(num_conti,i)=j
15300 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15301 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15302                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15303                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15304 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15305 !  terms.
15306                 d_cont(num_conti,i)=rij
15307 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15308 !     --- Electrostatic-interaction matrix ---
15309                 a_chuj(1,1,num_conti,i)=a22
15310                 a_chuj(1,2,num_conti,i)=a23
15311                 a_chuj(2,1,num_conti,i)=a32
15312                 a_chuj(2,2,num_conti,i)=a33
15313 !     --- Gradient of rij
15314                 do kkk=1,3
15315                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15316                 enddo
15317                 kkll=0
15318                 do k=1,2
15319                   do l=1,2
15320                     kkll=kkll+1
15321                     do m=1,3
15322                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15323                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15324                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15325                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15326                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15327                     enddo
15328                   enddo
15329                 enddo
15330                 ENDIF
15331                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15332 ! Calculate contact energies
15333                 cosa4=4.0D0*cosa
15334                 wij=cosa-3.0D0*cosb*cosg
15335                 cosbg1=cosb+cosg
15336                 cosbg2=cosb-cosg
15337 !               fac3=dsqrt(-ael6i)/r0ij**3
15338                 fac3=dsqrt(-ael6i)*r3ij
15339 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15340                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15341                 if (ees0tmp.gt.0) then
15342                   ees0pij=dsqrt(ees0tmp)
15343                 else
15344                   ees0pij=0
15345                 endif
15346 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15347                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15348                 if (ees0tmp.gt.0) then
15349                   ees0mij=dsqrt(ees0tmp)
15350                 else
15351                   ees0mij=0
15352                 endif
15353 !               ees0mij=0.0D0
15354                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15355                      *sss_ele_cut
15356
15357                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15358                      *sss_ele_cut
15359
15360 ! Diagnostics. Comment out or remove after debugging!
15361 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15362 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15363 !               ees0m(num_conti,i)=0.0D0
15364 ! End diagnostics.
15365 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15366 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15367 ! Angular derivatives of the contact function
15368                 ees0pij1=fac3/ees0pij
15369                 ees0mij1=fac3/ees0mij
15370                 fac3p=-3.0D0*fac3*rrmij
15371                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15372                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15373 !               ees0mij1=0.0D0
15374                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15375                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15376                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15377                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15378                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15379                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15380                 ecosap=ecosa1+ecosa2
15381                 ecosbp=ecosb1+ecosb2
15382                 ecosgp=ecosg1+ecosg2
15383                 ecosam=ecosa1-ecosa2
15384                 ecosbm=ecosb1-ecosb2
15385                 ecosgm=ecosg1-ecosg2
15386 ! Diagnostics
15387 !               ecosap=ecosa1
15388 !               ecosbp=ecosb1
15389 !               ecosgp=ecosg1
15390 !               ecosam=0.0D0
15391 !               ecosbm=0.0D0
15392 !               ecosgm=0.0D0
15393 ! End diagnostics
15394                 facont_hb(num_conti,i)=fcont
15395                 fprimcont=fprimcont/rij
15396 !d              facont_hb(num_conti,i)=1.0D0
15397 ! Following line is for diagnostics.
15398 !d              fprimcont=0.0D0
15399                 do k=1,3
15400                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15401                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15402                 enddo
15403                 do k=1,3
15404                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15405                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15406                 enddo
15407 !                gggp(1)=gggp(1)+ees0pijp*xj
15408 !                gggp(2)=gggp(2)+ees0pijp*yj
15409 !                gggp(3)=gggp(3)+ees0pijp*zj
15410 !                gggm(1)=gggm(1)+ees0mijp*xj
15411 !                gggm(2)=gggm(2)+ees0mijp*yj
15412 !                gggm(3)=gggm(3)+ees0mijp*zj
15413                 gggp(1)=gggp(1)+ees0pijp*xj &
15414                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15415                 gggp(2)=gggp(2)+ees0pijp*yj &
15416                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15417                 gggp(3)=gggp(3)+ees0pijp*zj &
15418                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15419
15420                 gggm(1)=gggm(1)+ees0mijp*xj &
15421                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15422
15423                 gggm(2)=gggm(2)+ees0mijp*yj &
15424                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15425
15426                 gggm(3)=gggm(3)+ees0mijp*zj &
15427                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15428
15429 ! Derivatives due to the contact function
15430                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15431                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15432                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15433                 do k=1,3
15434 !
15435 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15436 !          following the change of gradient-summation algorithm.
15437 !
15438 !grad                  ghalfp=0.5D0*gggp(k)
15439 !grad                  ghalfm=0.5D0*gggm(k)
15440 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15441 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15442 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15443 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15444 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15445 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15446 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15447 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15448 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15449 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15450 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15451 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15452 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15453 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15454                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15455                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15456                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15457                      *sss_ele_cut
15458
15459                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15460                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15461                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15462                      *sss_ele_cut
15463
15464                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15465                      *sss_ele_cut
15466
15467                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15468                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15469                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15470                      *sss_ele_cut
15471
15472                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15473                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15474                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15475                      *sss_ele_cut
15476
15477                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15478                      *sss_ele_cut
15479
15480                 enddo
15481               ENDIF ! wcorr
15482               endif  ! num_conti.le.maxconts
15483             endif  ! fcont.gt.0
15484           endif    ! j.gt.i+1
15485           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15486             do k=1,4
15487               do l=1,3
15488                 ghalf=0.5d0*agg(l,k)
15489                 aggi(l,k)=aggi(l,k)+ghalf
15490                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15491                 aggj(l,k)=aggj(l,k)+ghalf
15492               enddo
15493             enddo
15494             if (j.eq.nres-1 .and. i.lt.j-2) then
15495               do k=1,4
15496                 do l=1,3
15497                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15498                 enddo
15499               enddo
15500             endif
15501           endif
15502  128      continue
15503 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15504       return
15505       end subroutine eelecij_scale
15506 !-----------------------------------------------------------------------------
15507       subroutine evdwpp_short(evdw1)
15508 !
15509 ! Compute Evdwpp
15510 !
15511 !      implicit real*8 (a-h,o-z)
15512 !      include 'DIMENSIONS'
15513 !      include 'COMMON.CONTROL'
15514 !      include 'COMMON.IOUNITS'
15515 !      include 'COMMON.GEO'
15516 !      include 'COMMON.VAR'
15517 !      include 'COMMON.LOCAL'
15518 !      include 'COMMON.CHAIN'
15519 !      include 'COMMON.DERIV'
15520 !      include 'COMMON.INTERACT'
15521 !      include 'COMMON.CONTACTS'
15522 !      include 'COMMON.TORSION'
15523 !      include 'COMMON.VECTORS'
15524 !      include 'COMMON.FFIELD'
15525       real(kind=8),dimension(3) :: ggg
15526 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15527 #ifdef MOMENT
15528       real(kind=8) :: scal_el=1.0d0
15529 #else
15530       real(kind=8) :: scal_el=0.5d0
15531 #endif
15532 !el local variables
15533       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15534       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15535       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15536                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15537                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15538       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15539                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
15540                    sslipj,ssgradlipj,faclipij2
15541       integer xshift,yshift,zshift
15542
15543
15544       evdw1=0.0D0
15545 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15546 !     & " iatel_e_vdw",iatel_e_vdw
15547       call flush(iout)
15548       do i=iatel_s_vdw,iatel_e_vdw
15549         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15550         dxi=dc(1,i)
15551         dyi=dc(2,i)
15552         dzi=dc(3,i)
15553         dx_normi=dc_norm(1,i)
15554         dy_normi=dc_norm(2,i)
15555         dz_normi=dc_norm(3,i)
15556         xmedi=c(1,i)+0.5d0*dxi
15557         ymedi=c(2,i)+0.5d0*dyi
15558         zmedi=c(3,i)+0.5d0*dzi
15559         call to_box(xmedi,ymedi,zmedi)
15560         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15561         num_conti=0
15562 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15563 !     &   ' ielend',ielend_vdw(i)
15564         call flush(iout)
15565         do j=ielstart_vdw(i),ielend_vdw(i)
15566           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15567 !el          ind=ind+1
15568           iteli=itel(i)
15569           itelj=itel(j)
15570           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15571           aaa=app(iteli,itelj)
15572           bbb=bpp(iteli,itelj)
15573           dxj=dc(1,j)
15574           dyj=dc(2,j)
15575           dzj=dc(3,j)
15576           dx_normj=dc_norm(1,j)
15577           dy_normj=dc_norm(2,j)
15578           dz_normj=dc_norm(3,j)
15579 !          xj=c(1,j)+0.5D0*dxj-xmedi
15580 !          yj=c(2,j)+0.5D0*dyj-ymedi
15581 !          zj=c(3,j)+0.5D0*dzj-zmedi
15582           xj=c(1,j)+0.5D0*dxj
15583           yj=c(2,j)+0.5D0*dyj
15584           zj=c(3,j)+0.5D0*dzj
15585           call to_box(xj,yj,zj)
15586           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15587           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15588           xj=boxshift(xj-xmedi,boxxsize)
15589           yj=boxshift(yj-ymedi,boxysize)
15590           zj=boxshift(zj-zmedi,boxzsize)
15591           rij=xj*xj+yj*yj+zj*zj
15592           rrmij=1.0D0/rij
15593           rij=dsqrt(rij)
15594           sss=sscale(rij/rpp(iteli,itelj))
15595             sss_ele_cut=sscale_ele(rij)
15596             sss_ele_grad=sscagrad_ele(rij)
15597             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15598             if (sss_ele_cut.le.0.0) cycle
15599           if (sss.gt.0.0d0) then
15600             rmij=1.0D0/rij
15601             r3ij=rrmij*rmij
15602             r6ij=r3ij*r3ij
15603             ev1=aaa*r6ij*r6ij
15604 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15605             if (j.eq.i+2) ev1=scal_el*ev1
15606             ev2=bbb*r6ij
15607             evdwij=ev1+ev2
15608             if (energy_dec) then
15609               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15610             endif
15611             evdw1=evdw1+evdwij*sss*sss_ele_cut
15612 !
15613 ! Calculate contributions to the Cartesian gradient.
15614 !
15615             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15616 !            ggg(1)=facvdw*xj
15617 !            ggg(2)=facvdw*yj
15618 !            ggg(3)=facvdw*zj
15619           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15620           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15621           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15622           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15623           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15624           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15625
15626             do k=1,3
15627               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15628               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15629             enddo
15630           endif
15631         enddo ! j
15632       enddo   ! i
15633       return
15634       end subroutine evdwpp_short
15635 !-----------------------------------------------------------------------------
15636       subroutine escp_long(evdw2,evdw2_14)
15637 !
15638 ! This subroutine calculates the excluded-volume interaction energy between
15639 ! peptide-group centers and side chains and its gradient in virtual-bond and
15640 ! side-chain vectors.
15641 !
15642 !      implicit real*8 (a-h,o-z)
15643 !      include 'DIMENSIONS'
15644 !      include 'COMMON.GEO'
15645 !      include 'COMMON.VAR'
15646 !      include 'COMMON.LOCAL'
15647 !      include 'COMMON.CHAIN'
15648 !      include 'COMMON.DERIV'
15649 !      include 'COMMON.INTERACT'
15650 !      include 'COMMON.FFIELD'
15651 !      include 'COMMON.IOUNITS'
15652 !      include 'COMMON.CONTROL'
15653       real(kind=8),dimension(3) :: ggg
15654 !el local variables
15655       integer :: i,iint,j,k,iteli,itypj,subchap
15656       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15657       real(kind=8) :: evdw2,evdw2_14,evdwij
15658       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15659                     dist_temp, dist_init
15660
15661       evdw2=0.0D0
15662       evdw2_14=0.0d0
15663 !d    print '(a)','Enter ESCP'
15664 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15665       do i=iatscp_s,iatscp_e
15666         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15667         iteli=itel(i)
15668         xi=0.5D0*(c(1,i)+c(1,i+1))
15669         yi=0.5D0*(c(2,i)+c(2,i+1))
15670         zi=0.5D0*(c(3,i)+c(3,i+1))
15671         call to_box(xi,yi,zi)
15672         do iint=1,nscp_gr(i)
15673
15674         do j=iscpstart(i,iint),iscpend(i,iint)
15675           itypj=itype(j,1)
15676           if (itypj.eq.ntyp1) cycle
15677 ! Uncomment following three lines for SC-p interactions
15678 !         xj=c(1,nres+j)-xi
15679 !         yj=c(2,nres+j)-yi
15680 !         zj=c(3,nres+j)-zi
15681 ! Uncomment following three lines for Ca-p interactions
15682           xj=c(1,j)
15683           yj=c(2,j)
15684           zj=c(3,j)
15685           call to_box(xj,yj,zj)
15686           xj=boxshift(xj-xi,boxxsize)
15687           yj=boxshift(yj-yi,boxysize)
15688           zj=boxshift(zj-zi,boxzsize)
15689           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15690
15691           rij=dsqrt(1.0d0/rrij)
15692             sss_ele_cut=sscale_ele(rij)
15693             sss_ele_grad=sscagrad_ele(rij)
15694 !            print *,sss_ele_cut,sss_ele_grad,&
15695 !            (rij),r_cut_ele,rlamb_ele
15696             if (sss_ele_cut.le.0.0) cycle
15697           sss=sscale((rij/rscp(itypj,iteli)))
15698           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15699           if (sss.lt.1.0d0) then
15700
15701             fac=rrij**expon2
15702             e1=fac*fac*aad(itypj,iteli)
15703             e2=fac*bad(itypj,iteli)
15704             if (iabs(j-i) .le. 2) then
15705               e1=scal14*e1
15706               e2=scal14*e2
15707               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15708             endif
15709             evdwij=e1+e2
15710             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15711             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15712                 'evdw2',i,j,sss,evdwij
15713 !
15714 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15715 !
15716             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15717             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15718             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15719             ggg(1)=xj*fac
15720             ggg(2)=yj*fac
15721             ggg(3)=zj*fac
15722 ! Uncomment following three lines for SC-p interactions
15723 !           do k=1,3
15724 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15725 !           enddo
15726 ! Uncomment following line for SC-p interactions
15727 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15728             do k=1,3
15729               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15730               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15731             enddo
15732           endif
15733         enddo
15734
15735         enddo ! iint
15736       enddo ! i
15737       do i=1,nct
15738         do j=1,3
15739           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15740           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15741           gradx_scp(j,i)=expon*gradx_scp(j,i)
15742         enddo
15743       enddo
15744 !******************************************************************************
15745 !
15746 !                              N O T E !!!
15747 !
15748 ! To save time the factor EXPON has been extracted from ALL components
15749 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15750 ! use!
15751 !
15752 !******************************************************************************
15753       return
15754       end subroutine escp_long
15755 !-----------------------------------------------------------------------------
15756       subroutine escp_short(evdw2,evdw2_14)
15757 !
15758 ! This subroutine calculates the excluded-volume interaction energy between
15759 ! peptide-group centers and side chains and its gradient in virtual-bond and
15760 ! side-chain vectors.
15761 !
15762 !      implicit real*8 (a-h,o-z)
15763 !      include 'DIMENSIONS'
15764 !      include 'COMMON.GEO'
15765 !      include 'COMMON.VAR'
15766 !      include 'COMMON.LOCAL'
15767 !      include 'COMMON.CHAIN'
15768 !      include 'COMMON.DERIV'
15769 !      include 'COMMON.INTERACT'
15770 !      include 'COMMON.FFIELD'
15771 !      include 'COMMON.IOUNITS'
15772 !      include 'COMMON.CONTROL'
15773       real(kind=8),dimension(3) :: ggg
15774 !el local variables
15775       integer :: i,iint,j,k,iteli,itypj,subchap
15776       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15777       real(kind=8) :: evdw2,evdw2_14,evdwij
15778       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15779                     dist_temp, dist_init
15780
15781       evdw2=0.0D0
15782       evdw2_14=0.0d0
15783 !d    print '(a)','Enter ESCP'
15784 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15785       do i=iatscp_s,iatscp_e
15786         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15787         iteli=itel(i)
15788         xi=0.5D0*(c(1,i)+c(1,i+1))
15789         yi=0.5D0*(c(2,i)+c(2,i+1))
15790         zi=0.5D0*(c(3,i)+c(3,i+1))
15791         call to_box(xi,yi,zi)
15792         if (zi.lt.0) zi=zi+boxzsize
15793
15794         do iint=1,nscp_gr(i)
15795
15796         do j=iscpstart(i,iint),iscpend(i,iint)
15797           itypj=itype(j,1)
15798           if (itypj.eq.ntyp1) cycle
15799 ! Uncomment following three lines for SC-p interactions
15800 !         xj=c(1,nres+j)-xi
15801 !         yj=c(2,nres+j)-yi
15802 !         zj=c(3,nres+j)-zi
15803 ! Uncomment following three lines for Ca-p interactions
15804 !          xj=c(1,j)-xi
15805 !          yj=c(2,j)-yi
15806 !          zj=c(3,j)-zi
15807           xj=c(1,j)
15808           yj=c(2,j)
15809           zj=c(3,j)
15810           call to_box(xj,yj,zj)
15811           xj=boxshift(xj-xi,boxxsize)
15812           yj=boxshift(yj-yi,boxysize)
15813           zj=boxshift(zj-zi,boxzsize)
15814           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15815           rij=dsqrt(1.0d0/rrij)
15816             sss_ele_cut=sscale_ele(rij)
15817             sss_ele_grad=sscagrad_ele(rij)
15818 !            print *,sss_ele_cut,sss_ele_grad,&
15819 !            (rij),r_cut_ele,rlamb_ele
15820             if (sss_ele_cut.le.0.0) cycle
15821           sss=sscale(rij/rscp(itypj,iteli))
15822           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15823           if (sss.gt.0.0d0) then
15824
15825             fac=rrij**expon2
15826             e1=fac*fac*aad(itypj,iteli)
15827             e2=fac*bad(itypj,iteli)
15828             if (iabs(j-i) .le. 2) then
15829               e1=scal14*e1
15830               e2=scal14*e2
15831               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15832             endif
15833             evdwij=e1+e2
15834             evdw2=evdw2+evdwij*sss*sss_ele_cut
15835             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15836                 'evdw2',i,j,sss,evdwij
15837 !
15838 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15839 !
15840             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15841             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15842             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15843
15844             ggg(1)=xj*fac
15845             ggg(2)=yj*fac
15846             ggg(3)=zj*fac
15847 ! Uncomment following three lines for SC-p interactions
15848 !           do k=1,3
15849 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15850 !           enddo
15851 ! Uncomment following line for SC-p interactions
15852 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15853             do k=1,3
15854               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15855               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15856             enddo
15857           endif
15858         enddo
15859
15860         enddo ! iint
15861       enddo ! i
15862       do i=1,nct
15863         do j=1,3
15864           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15865           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15866           gradx_scp(j,i)=expon*gradx_scp(j,i)
15867         enddo
15868       enddo
15869 !******************************************************************************
15870 !
15871 !                              N O T E !!!
15872 !
15873 ! To save time the factor EXPON has been extracted from ALL components
15874 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15875 ! use!
15876 !
15877 !******************************************************************************
15878       return
15879       end subroutine escp_short
15880 !-----------------------------------------------------------------------------
15881 ! energy_p_new-sep_barrier.F
15882 !-----------------------------------------------------------------------------
15883       subroutine sc_grad_scale(scalfac)
15884 !      implicit real*8 (a-h,o-z)
15885       use calc_data
15886 !      include 'DIMENSIONS'
15887 !      include 'COMMON.CHAIN'
15888 !      include 'COMMON.DERIV'
15889 !      include 'COMMON.CALC'
15890 !      include 'COMMON.IOUNITS'
15891       real(kind=8),dimension(3) :: dcosom1,dcosom2
15892       real(kind=8) :: scalfac
15893 !el local variables
15894 !      integer :: i,j,k,l
15895
15896       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15897       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15898       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15899            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15900 ! diagnostics only
15901 !      eom1=0.0d0
15902 !      eom2=0.0d0
15903 !      eom12=evdwij*eps1_om12
15904 ! end diagnostics
15905 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15906 !     &  " sigder",sigder
15907 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15908 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15909       do k=1,3
15910         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15911         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15912       enddo
15913       do k=1,3
15914         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15915          *sss_ele_cut
15916       enddo
15917 !      write (iout,*) "gg",(gg(k),k=1,3)
15918       do k=1,3
15919         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15920                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15921                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15922                  *sss_ele_cut
15923         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15924                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15925                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15926          *sss_ele_cut
15927 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15928 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15929 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15930 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15931       enddo
15932 !
15933 ! Calculate the components of the gradient in DC and X
15934 !
15935       do l=1,3
15936         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15937         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15938       enddo
15939       return
15940       end subroutine sc_grad_scale
15941 !-----------------------------------------------------------------------------
15942 ! energy_split-sep.F
15943 !-----------------------------------------------------------------------------
15944       subroutine etotal_long(energia)
15945 !
15946 ! Compute the long-range slow-varying contributions to the energy
15947 !
15948 !      implicit real*8 (a-h,o-z)
15949 !      include 'DIMENSIONS'
15950       use MD_data, only: totT,usampl,eq_time
15951 #ifndef ISNAN
15952       external proc_proc
15953 #ifdef WINPGI
15954 !MS$ATTRIBUTES C ::  proc_proc
15955 #endif
15956 #endif
15957 #ifdef MPI
15958       include "mpif.h"
15959       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15960 #endif
15961 !      include 'COMMON.SETUP'
15962 !      include 'COMMON.IOUNITS'
15963 !      include 'COMMON.FFIELD'
15964 !      include 'COMMON.DERIV'
15965 !      include 'COMMON.INTERACT'
15966 !      include 'COMMON.SBRIDGE'
15967 !      include 'COMMON.CHAIN'
15968 !      include 'COMMON.VAR'
15969 !      include 'COMMON.LOCAL'
15970 !      include 'COMMON.MD'
15971       real(kind=8),dimension(0:n_ene) :: energia
15972 !el local variables
15973       integer :: i,n_corr,n_corr1,ierror,ierr
15974       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15975                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15976                   ecorr,ecorr5,ecorr6,eturn6,time00
15977 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15978 !elwrite(iout,*)"in etotal long"
15979
15980       if (modecalc.eq.12.or.modecalc.eq.14) then
15981 #ifdef MPI
15982 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15983 #else
15984         call int_from_cart1(.false.)
15985 #endif
15986       endif
15987 !elwrite(iout,*)"in etotal long"
15988
15989 #ifdef MPI
15990 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15991 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15992       call flush(iout)
15993       if (nfgtasks.gt.1) then
15994         time00=MPI_Wtime()
15995 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15996         if (fg_rank.eq.0) then
15997           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15998 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15999 !          call flush(iout)
16000 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16001 ! FG slaves as WEIGHTS array.
16002           weights_(1)=wsc
16003           weights_(2)=wscp
16004           weights_(3)=welec
16005           weights_(4)=wcorr
16006           weights_(5)=wcorr5
16007           weights_(6)=wcorr6
16008           weights_(7)=wel_loc
16009           weights_(8)=wturn3
16010           weights_(9)=wturn4
16011           weights_(10)=wturn6
16012           weights_(11)=wang
16013           weights_(12)=wscloc
16014           weights_(13)=wtor
16015           weights_(14)=wtor_d
16016           weights_(15)=wstrain
16017           weights_(16)=wvdwpp
16018           weights_(17)=wbond
16019           weights_(18)=scal14
16020           weights_(21)=wsccor
16021 ! FG Master broadcasts the WEIGHTS_ array
16022           call MPI_Bcast(weights_(1),n_ene,&
16023               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16024         else
16025 ! FG slaves receive the WEIGHTS array
16026           call MPI_Bcast(weights(1),n_ene,&
16027               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16028           wsc=weights(1)
16029           wscp=weights(2)
16030           welec=weights(3)
16031           wcorr=weights(4)
16032           wcorr5=weights(5)
16033           wcorr6=weights(6)
16034           wel_loc=weights(7)
16035           wturn3=weights(8)
16036           wturn4=weights(9)
16037           wturn6=weights(10)
16038           wang=weights(11)
16039           wscloc=weights(12)
16040           wtor=weights(13)
16041           wtor_d=weights(14)
16042           wstrain=weights(15)
16043           wvdwpp=weights(16)
16044           wbond=weights(17)
16045           scal14=weights(18)
16046           wsccor=weights(21)
16047         endif
16048         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16049           king,FG_COMM,IERR)
16050          time_Bcast=time_Bcast+MPI_Wtime()-time00
16051          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16052 !        call chainbuild_cart
16053 !        call int_from_cart1(.false.)
16054       endif
16055 !      write (iout,*) 'Processor',myrank,
16056 !     &  ' calling etotal_short ipot=',ipot
16057 !      call flush(iout)
16058 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16059 #endif
16060 !d    print *,'nnt=',nnt,' nct=',nct
16061 !
16062 !elwrite(iout,*)"in etotal long"
16063 ! Compute the side-chain and electrostatic interaction energy
16064 !
16065       goto (101,102,103,104,105,106) ipot
16066 ! Lennard-Jones potential.
16067   101 call elj_long(evdw)
16068 !d    print '(a)','Exit ELJ'
16069       goto 107
16070 ! Lennard-Jones-Kihara potential (shifted).
16071   102 call eljk_long(evdw)
16072       goto 107
16073 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16074   103 call ebp_long(evdw)
16075       goto 107
16076 ! Gay-Berne potential (shifted LJ, angular dependence).
16077   104 call egb_long(evdw)
16078       goto 107
16079 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16080   105 call egbv_long(evdw)
16081       goto 107
16082 ! Soft-sphere potential
16083   106 call e_softsphere(evdw)
16084 !
16085 ! Calculate electrostatic (H-bonding) energy of the main chain.
16086 !
16087   107 continue
16088       call vec_and_deriv
16089       if (ipot.lt.6) then
16090 #ifdef SPLITELE
16091          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16092              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16093              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16094              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16095 #else
16096          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16097              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16098              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16099              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16100 #endif
16101            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16102          else
16103             ees=0
16104             evdw1=0
16105             eel_loc=0
16106             eello_turn3=0
16107             eello_turn4=0
16108          endif
16109       else
16110 !        write (iout,*) "Soft-spheer ELEC potential"
16111         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16112          eello_turn4)
16113       endif
16114 !
16115 ! Calculate excluded-volume interaction energy between peptide groups
16116 ! and side chains.
16117 !
16118       if (ipot.lt.6) then
16119        if(wscp.gt.0d0) then
16120         call escp_long(evdw2,evdw2_14)
16121        else
16122         evdw2=0
16123         evdw2_14=0
16124        endif
16125       else
16126         call escp_soft_sphere(evdw2,evdw2_14)
16127       endif
16128 !
16129 ! 12/1/95 Multi-body terms
16130 !
16131       n_corr=0
16132       n_corr1=0
16133       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16134           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16135          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16136 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16137 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16138       else
16139          ecorr=0.0d0
16140          ecorr5=0.0d0
16141          ecorr6=0.0d0
16142          eturn6=0.0d0
16143       endif
16144       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16145          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16146       endif
16147 !
16148 ! If performing constraint dynamics, call the constraint energy
16149 !  after the equilibration time
16150       if(usampl.and.totT.gt.eq_time) then
16151          call EconstrQ
16152          call Econstr_back
16153       else
16154          Uconst=0.0d0
16155          Uconst_back=0.0d0
16156       endif
16157 !
16158 ! Sum the energies
16159 !
16160       do i=1,n_ene
16161         energia(i)=0.0d0
16162       enddo
16163       energia(1)=evdw
16164 #ifdef SCP14
16165       energia(2)=evdw2-evdw2_14
16166       energia(18)=evdw2_14
16167 #else
16168       energia(2)=evdw2
16169       energia(18)=0.0d0
16170 #endif
16171 #ifdef SPLITELE
16172       energia(3)=ees
16173       energia(16)=evdw1
16174 #else
16175       energia(3)=ees+evdw1
16176       energia(16)=0.0d0
16177 #endif
16178       energia(4)=ecorr
16179       energia(5)=ecorr5
16180       energia(6)=ecorr6
16181       energia(7)=eel_loc
16182       energia(8)=eello_turn3
16183       energia(9)=eello_turn4
16184       energia(10)=eturn6
16185       energia(20)=Uconst+Uconst_back
16186       call sum_energy(energia,.true.)
16187 !      write (iout,*) "Exit ETOTAL_LONG"
16188       call flush(iout)
16189       return
16190       end subroutine etotal_long
16191 !-----------------------------------------------------------------------------
16192       subroutine etotal_short(energia)
16193 !
16194 ! Compute the short-range fast-varying contributions to the energy
16195 !
16196 !      implicit real*8 (a-h,o-z)
16197 !      include 'DIMENSIONS'
16198 #ifndef ISNAN
16199       external proc_proc
16200 #ifdef WINPGI
16201 !MS$ATTRIBUTES C ::  proc_proc
16202 #endif
16203 #endif
16204 #ifdef MPI
16205       include "mpif.h"
16206       integer :: ierror,ierr
16207       real(kind=8),dimension(n_ene) :: weights_
16208       real(kind=8) :: time00
16209 #endif
16210 !      include 'COMMON.SETUP'
16211 !      include 'COMMON.IOUNITS'
16212 !      include 'COMMON.FFIELD'
16213 !      include 'COMMON.DERIV'
16214 !      include 'COMMON.INTERACT'
16215 !      include 'COMMON.SBRIDGE'
16216 !      include 'COMMON.CHAIN'
16217 !      include 'COMMON.VAR'
16218 !      include 'COMMON.LOCAL'
16219       real(kind=8),dimension(0:n_ene) :: energia
16220 !el local variables
16221       integer :: i,nres6
16222       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16223       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16224       nres6=6*nres
16225
16226 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16227 !      call flush(iout)
16228       if (modecalc.eq.12.or.modecalc.eq.14) then
16229 #ifdef MPI
16230         if (fg_rank.eq.0) call int_from_cart1(.false.)
16231 #else
16232         call int_from_cart1(.false.)
16233 #endif
16234       endif
16235 #ifdef MPI
16236 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16237 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16238 !      call flush(iout)
16239       if (nfgtasks.gt.1) then
16240         time00=MPI_Wtime()
16241 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16242         if (fg_rank.eq.0) then
16243           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16244 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16245 !          call flush(iout)
16246 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16247 ! FG slaves as WEIGHTS array.
16248           weights_(1)=wsc
16249           weights_(2)=wscp
16250           weights_(3)=welec
16251           weights_(4)=wcorr
16252           weights_(5)=wcorr5
16253           weights_(6)=wcorr6
16254           weights_(7)=wel_loc
16255           weights_(8)=wturn3
16256           weights_(9)=wturn4
16257           weights_(10)=wturn6
16258           weights_(11)=wang
16259           weights_(12)=wscloc
16260           weights_(13)=wtor
16261           weights_(14)=wtor_d
16262           weights_(15)=wstrain
16263           weights_(16)=wvdwpp
16264           weights_(17)=wbond
16265           weights_(18)=scal14
16266           weights_(21)=wsccor
16267 ! FG Master broadcasts the WEIGHTS_ array
16268           call MPI_Bcast(weights_(1),n_ene,&
16269               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16270         else
16271 ! FG slaves receive the WEIGHTS array
16272           call MPI_Bcast(weights(1),n_ene,&
16273               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16274           wsc=weights(1)
16275           wscp=weights(2)
16276           welec=weights(3)
16277           wcorr=weights(4)
16278           wcorr5=weights(5)
16279           wcorr6=weights(6)
16280           wel_loc=weights(7)
16281           wturn3=weights(8)
16282           wturn4=weights(9)
16283           wturn6=weights(10)
16284           wang=weights(11)
16285           wscloc=weights(12)
16286           wtor=weights(13)
16287           wtor_d=weights(14)
16288           wstrain=weights(15)
16289           wvdwpp=weights(16)
16290           wbond=weights(17)
16291           scal14=weights(18)
16292           wsccor=weights(21)
16293         endif
16294 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16295         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16296           king,FG_COMM,IERR)
16297 !        write (iout,*) "Processor",myrank," BROADCAST c"
16298         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16299           king,FG_COMM,IERR)
16300 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16301         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16302           king,FG_COMM,IERR)
16303 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16304         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16305           king,FG_COMM,IERR)
16306 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16307         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16308           king,FG_COMM,IERR)
16309 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16310         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16311           king,FG_COMM,IERR)
16312 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16313         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16314           king,FG_COMM,IERR)
16315 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16316         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16317           king,FG_COMM,IERR)
16318 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16319         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16320           king,FG_COMM,IERR)
16321          time_Bcast=time_Bcast+MPI_Wtime()-time00
16322 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16323       endif
16324 !      write (iout,*) 'Processor',myrank,
16325 !     &  ' calling etotal_short ipot=',ipot
16326 !      call flush(iout)
16327 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16328 #endif
16329 !      call int_from_cart1(.false.)
16330 !
16331 ! Compute the side-chain and electrostatic interaction energy
16332 !
16333       goto (101,102,103,104,105,106) ipot
16334 ! Lennard-Jones potential.
16335   101 call elj_short(evdw)
16336 !d    print '(a)','Exit ELJ'
16337       goto 107
16338 ! Lennard-Jones-Kihara potential (shifted).
16339   102 call eljk_short(evdw)
16340       goto 107
16341 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16342   103 call ebp_short(evdw)
16343       goto 107
16344 ! Gay-Berne potential (shifted LJ, angular dependence).
16345   104 call egb_short(evdw)
16346       goto 107
16347 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16348   105 call egbv_short(evdw)
16349       goto 107
16350 ! Soft-sphere potential - already dealt with in the long-range part
16351   106 evdw=0.0d0
16352 !  106 call e_softsphere_short(evdw)
16353 !
16354 ! Calculate electrostatic (H-bonding) energy of the main chain.
16355 !
16356   107 continue
16357 !
16358 ! Calculate the short-range part of Evdwpp
16359 !
16360       call evdwpp_short(evdw1)
16361 !
16362 ! Calculate the short-range part of ESCp
16363 !
16364       if (ipot.lt.6) then
16365        call escp_short(evdw2,evdw2_14)
16366       endif
16367 !
16368 ! Calculate the bond-stretching energy
16369 !
16370       call ebond(estr)
16371 !
16372 ! Calculate the disulfide-bridge and other energy and the contributions
16373 ! from other distance constraints.
16374       call edis(ehpb)
16375 !
16376 ! Calculate the virtual-bond-angle energy.
16377 !
16378 ! Calculate the SC local energy.
16379 !
16380       call vec_and_deriv
16381       call esc(escloc)
16382 !
16383       if (wang.gt.0d0) then
16384        if (tor_mode.eq.0) then
16385            call ebend(ebe)
16386        else
16387 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16388 !C energy function
16389         call ebend_kcc(ebe)
16390        endif
16391       else
16392           ebe=0.0d0
16393       endif
16394       ethetacnstr=0.0d0
16395       if (with_theta_constr) call etheta_constr(ethetacnstr)
16396
16397 !       write(iout,*) "in etotal afer ebe",ipot
16398
16399 !      print *,"Processor",myrank," computed UB"
16400 !
16401 ! Calculate the SC local energy.
16402 !
16403       call esc(escloc)
16404 !elwrite(iout,*) "in etotal afer esc",ipot
16405 !      print *,"Processor",myrank," computed USC"
16406 !
16407 ! Calculate the virtual-bond torsional energy.
16408 !
16409 !d    print *,'nterm=',nterm
16410 !      if (wtor.gt.0) then
16411 !       call etor(etors,edihcnstr)
16412 !      else
16413 !       etors=0
16414 !       edihcnstr=0
16415 !      endif
16416       if (wtor.gt.0.0d0) then
16417          if (tor_mode.eq.0) then
16418            call etor(etors)
16419           else
16420 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16421 !C energy function
16422         call etor_kcc(etors)
16423          endif
16424       else
16425            etors=0.0d0
16426       endif
16427       edihcnstr=0.0d0
16428       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16429
16430 ! Calculate the virtual-bond torsional energy.
16431 !
16432 !
16433 ! 6/23/01 Calculate double-torsional energy
16434 !
16435       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16436       call etor_d(etors_d)
16437       endif
16438 !
16439 ! 21/5/07 Calculate local sicdechain correlation energy
16440 !
16441       if (wsccor.gt.0.0d0) then
16442        call eback_sc_corr(esccor)
16443       else
16444        esccor=0.0d0
16445       endif
16446 !
16447 ! Put energy components into an array
16448 !
16449       do i=1,n_ene
16450        energia(i)=0.0d0
16451       enddo
16452       energia(1)=evdw
16453 #ifdef SCP14
16454       energia(2)=evdw2-evdw2_14
16455       energia(18)=evdw2_14
16456 #else
16457       energia(2)=evdw2
16458       energia(18)=0.0d0
16459 #endif
16460 #ifdef SPLITELE
16461       energia(16)=evdw1
16462 #else
16463       energia(3)=evdw1
16464 #endif
16465       energia(11)=ebe
16466       energia(12)=escloc
16467       energia(13)=etors
16468       energia(14)=etors_d
16469       energia(15)=ehpb
16470       energia(17)=estr
16471       energia(19)=edihcnstr
16472       energia(21)=esccor
16473 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16474       call flush(iout)
16475       call sum_energy(energia,.true.)
16476 !      write (iout,*) "Exit ETOTAL_SHORT"
16477       call flush(iout)
16478       return
16479       end subroutine etotal_short
16480 !-----------------------------------------------------------------------------
16481 ! gnmr1.f
16482 !-----------------------------------------------------------------------------
16483       real(kind=8) function gnmr1(y,ymin,ymax)
16484 !      implicit none
16485       real(kind=8) :: y,ymin,ymax
16486       real(kind=8) :: wykl=4.0d0
16487       if (y.lt.ymin) then
16488         gnmr1=(ymin-y)**wykl/wykl
16489       else if (y.gt.ymax) then
16490        gnmr1=(y-ymax)**wykl/wykl
16491       else
16492        gnmr1=0.0d0
16493       endif
16494       return
16495       end function gnmr1
16496 !-----------------------------------------------------------------------------
16497       real(kind=8) function gnmr1prim(y,ymin,ymax)
16498 !      implicit none
16499       real(kind=8) :: y,ymin,ymax
16500       real(kind=8) :: wykl=4.0d0
16501       if (y.lt.ymin) then
16502        gnmr1prim=-(ymin-y)**(wykl-1)
16503       else if (y.gt.ymax) then
16504        gnmr1prim=(y-ymax)**(wykl-1)
16505       else
16506        gnmr1prim=0.0d0
16507       endif
16508       return
16509       end function gnmr1prim
16510 !----------------------------------------------------------------------------
16511       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16512       real(kind=8) y,ymin,ymax,sigma
16513       real(kind=8) wykl /4.0d0/
16514       if (y.lt.ymin) then
16515         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16516       else if (y.gt.ymax) then
16517        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16518       else
16519         rlornmr1=0.0d0
16520       endif
16521       return
16522       end function rlornmr1
16523 !------------------------------------------------------------------------------
16524       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16525       real(kind=8) y,ymin,ymax,sigma
16526       real(kind=8) wykl /4.0d0/
16527       if (y.lt.ymin) then
16528         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16529         ((ymin-y)**wykl+sigma**wykl)**2
16530       else if (y.gt.ymax) then
16531          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16532         ((y-ymax)**wykl+sigma**wykl)**2
16533       else
16534        rlornmr1prim=0.0d0
16535       endif
16536       return
16537       end function rlornmr1prim
16538
16539       real(kind=8) function harmonic(y,ymax)
16540 !      implicit none
16541       real(kind=8) :: y,ymax
16542       real(kind=8) :: wykl=2.0d0
16543       harmonic=(y-ymax)**wykl
16544       return
16545       end function harmonic
16546 !-----------------------------------------------------------------------------
16547       real(kind=8) function harmonicprim(y,ymax)
16548       real(kind=8) :: y,ymin,ymax
16549       real(kind=8) :: wykl=2.0d0
16550       harmonicprim=(y-ymax)*wykl
16551       return
16552       end function harmonicprim
16553 !-----------------------------------------------------------------------------
16554 ! gradient_p.F
16555 !-----------------------------------------------------------------------------
16556       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16557
16558       use io_base, only:intout,briefout
16559 !      implicit real*8 (a-h,o-z)
16560 !      include 'DIMENSIONS'
16561 !      include 'COMMON.CHAIN'
16562 !      include 'COMMON.DERIV'
16563 !      include 'COMMON.VAR'
16564 !      include 'COMMON.INTERACT'
16565 !      include 'COMMON.FFIELD'
16566 !      include 'COMMON.MD'
16567 !      include 'COMMON.IOUNITS'
16568       real(kind=8),external :: ufparm
16569       integer :: uiparm(1)
16570       real(kind=8) :: urparm(1)
16571       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16572       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16573       integer :: n,nf,ind,ind1,i,k,j
16574 !
16575 ! This subroutine calculates total internal coordinate gradient.
16576 ! Depending on the number of function evaluations, either whole energy
16577 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16578 ! internal coordinates are reevaluated or only the cartesian-in-internal
16579 ! coordinate derivatives are evaluated. The subroutine was designed to work
16580 ! with SUMSL.
16581 !
16582 !
16583       icg=mod(nf,2)+1
16584
16585 !d      print *,'grad',nf,icg
16586       if (nf-nfl+1) 20,30,40
16587    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16588 !    write (iout,*) 'grad 20'
16589       if (nf.eq.0) return
16590       goto 40
16591    30 call var_to_geom(n,x)
16592       call chainbuild
16593 !    write (iout,*) 'grad 30'
16594 !
16595 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16596 !
16597    40 call cartder
16598 !     write (iout,*) 'grad 40'
16599 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16600 !
16601 ! Convert the Cartesian gradient into internal-coordinate gradient.
16602 !
16603       ind=0
16604       ind1=0
16605       do i=1,nres-2
16606       gthetai=0.0D0
16607       gphii=0.0D0
16608       do j=i+1,nres-1
16609         ind=ind+1
16610 !         ind=indmat(i,j)
16611 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16612        do k=1,3
16613        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16614         enddo
16615         do k=1,3
16616         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16617          enddo
16618        enddo
16619       do j=i+1,nres-1
16620         ind1=ind1+1
16621 !         ind1=indmat(i,j)
16622 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16623         do k=1,3
16624           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16625           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16626           enddo
16627         enddo
16628       if (i.gt.1) g(i-1)=gphii
16629       if (n.gt.nphi) g(nphi+i)=gthetai
16630       enddo
16631       if (n.le.nphi+ntheta) goto 10
16632       do i=2,nres-1
16633       if (itype(i,1).ne.10) then
16634           galphai=0.0D0
16635         gomegai=0.0D0
16636         do k=1,3
16637           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16638           enddo
16639         do k=1,3
16640           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16641           enddo
16642           g(ialph(i,1))=galphai
16643         g(ialph(i,1)+nside)=gomegai
16644         endif
16645       enddo
16646 !
16647 ! Add the components corresponding to local energy terms.
16648 !
16649    10 continue
16650       do i=1,nvar
16651 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16652         g(i)=g(i)+gloc(i,icg)
16653       enddo
16654 ! Uncomment following three lines for diagnostics.
16655 !d    call intout
16656 !elwrite(iout,*) "in gradient after calling intout"
16657 !d    call briefout(0,0.0d0)
16658 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16659       return
16660       end subroutine gradient
16661 !-----------------------------------------------------------------------------
16662       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16663
16664       use comm_chu
16665 !      implicit real*8 (a-h,o-z)
16666 !      include 'DIMENSIONS'
16667 !      include 'COMMON.DERIV'
16668 !      include 'COMMON.IOUNITS'
16669 !      include 'COMMON.GEO'
16670       integer :: n,nf
16671 !el      integer :: jjj
16672 !el      common /chuju/ jjj
16673       real(kind=8) :: energia(0:n_ene)
16674       integer :: uiparm(1)
16675       real(kind=8) :: urparm(1)
16676       real(kind=8) :: f
16677       real(kind=8),external :: ufparm
16678       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16679 !     if (jjj.gt.0) then
16680 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16681 !     endif
16682       nfl=nf
16683       icg=mod(nf,2)+1
16684 !d      print *,'func',nf,nfl,icg
16685       call var_to_geom(n,x)
16686       call zerograd
16687       call chainbuild
16688 !d    write (iout,*) 'ETOTAL called from FUNC'
16689       call etotal(energia)
16690       call sum_gradient
16691       f=energia(0)
16692 !     if (jjj.gt.0) then
16693 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16694 !       write (iout,*) 'f=',etot
16695 !       jjj=0
16696 !     endif
16697       return
16698       end subroutine func
16699 !-----------------------------------------------------------------------------
16700       subroutine cartgrad
16701 !      implicit real*8 (a-h,o-z)
16702 !      include 'DIMENSIONS'
16703       use energy_data
16704       use MD_data, only: totT,usampl,eq_time
16705 #ifdef MPI
16706       include 'mpif.h'
16707 #endif
16708 !      include 'COMMON.CHAIN'
16709 !      include 'COMMON.DERIV'
16710 !      include 'COMMON.VAR'
16711 !      include 'COMMON.INTERACT'
16712 !      include 'COMMON.FFIELD'
16713 !      include 'COMMON.MD'
16714 !      include 'COMMON.IOUNITS'
16715 !      include 'COMMON.TIME1'
16716 !
16717       integer :: i,j
16718       real(kind=8) :: time00,time01
16719
16720 ! This subrouting calculates total Cartesian coordinate gradient.
16721 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16722 !
16723 !#define DEBUG
16724 #ifdef TIMINGtime01
16725       time00=MPI_Wtime()
16726 #endif
16727       icg=1
16728       call sum_gradient
16729 #ifdef TIMING
16730 #endif
16731 !#define DEBUG
16732 !el      write (iout,*) "After sum_gradient"
16733 #ifdef DEBUG
16734       write (iout,*) "After sum_gradient"
16735       do i=1,nres-1
16736         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16737         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16738       enddo
16739 #endif
16740 !#undef DEBUG
16741 ! If performing constraint dynamics, add the gradients of the constraint energy
16742       if(usampl.and.totT.gt.eq_time) then
16743          do i=1,nct
16744            do j=1,3
16745              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16746              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16747            enddo
16748          enddo
16749          do i=1,nres-3
16750            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16751          enddo
16752          do i=1,nres-2
16753            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16754          enddo
16755       endif
16756 !elwrite (iout,*) "After sum_gradient"
16757 #ifdef TIMING
16758       time01=MPI_Wtime()
16759 #endif
16760       call intcartderiv
16761 !elwrite (iout,*) "After sum_gradient"
16762 #ifdef TIMING
16763       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16764 #endif
16765 !     call checkintcartgrad
16766 !     write(iout,*) 'calling int_to_cart'
16767 !#define DEBUG
16768 #ifdef DEBUG
16769       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16770 #endif
16771       do i=0,nct
16772         do j=1,3
16773           gcart(j,i)=gradc(j,i,icg)
16774           gxcart(j,i)=gradx(j,i,icg)
16775 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16776         enddo
16777 #ifdef DEBUG
16778         write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),&
16779           (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3)
16780 #endif
16781       enddo
16782 #ifdef TIMING
16783       time01=MPI_Wtime()
16784 #endif
16785 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16786       call int_to_cart
16787 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16788
16789 #ifdef TIMING
16790             time_inttocart=time_inttocart+MPI_Wtime()-time01
16791 #endif
16792 #ifdef DEBUG
16793             write (iout,*) "gcart and gxcart after int_to_cart"
16794             do i=0,nres-1
16795             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16796             (gxcart(j,i),j=1,3)
16797             enddo
16798 #endif
16799 !#undef DEBUG
16800 #ifdef CARGRAD
16801 #ifdef DEBUG
16802             write (iout,*) "CARGRAD"
16803 #endif
16804             do i=nres,0,-1
16805             do j=1,3
16806               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16807       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16808             enddo
16809       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16810       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16811             enddo
16812       ! Correction: dummy residues
16813             if (nnt.gt.1) then
16814               do j=1,3
16815       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16816             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16817             enddo
16818           endif
16819           if (nct.lt.nres) then
16820             do j=1,3
16821       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16822             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16823             enddo
16824           endif
16825 #endif
16826 #ifdef TIMING
16827           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16828 #endif
16829 !#undef DEBUG
16830           return
16831           end subroutine cartgrad
16832       !-----------------------------------------------------------------------------
16833           subroutine zerograd
16834       !      implicit real*8 (a-h,o-z)
16835       !      include 'DIMENSIONS'
16836       !      include 'COMMON.DERIV'
16837       !      include 'COMMON.CHAIN'
16838       !      include 'COMMON.VAR'
16839       !      include 'COMMON.MD'
16840       !      include 'COMMON.SCCOR'
16841       !
16842       !el local variables
16843           integer :: i,j,intertyp,k
16844       ! Initialize Cartesian-coordinate gradient
16845       !
16846       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16847       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16848
16849       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16850       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16851       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16852       !      allocate(gradcorr_long(3,nres))
16853       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16854       !      allocate(gcorr6_turn_long(3,nres))
16855       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16856
16857       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16858
16859       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16860       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16861
16862       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16863       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16864
16865       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16866       !      allocate(gscloc(3,nres)) !(3,maxres)
16867       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16868
16869
16870
16871       !      common /deriv_scloc/
16872       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16873       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16874       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16875       !      common /mpgrad/
16876       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16877
16878
16879
16880       !          gradc(j,i,icg)=0.0d0
16881       !          gradx(j,i,icg)=0.0d0
16882
16883       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16884       !elwrite(iout,*) "icg",icg
16885           do i=-1,nres
16886           do j=1,3
16887             gvdwx(j,i)=0.0D0
16888             gradx_scp(j,i)=0.0D0
16889             gvdwc(j,i)=0.0D0
16890             gvdwc_scp(j,i)=0.0D0
16891             gvdwc_scpp(j,i)=0.0d0
16892             gelc(j,i)=0.0D0
16893             gelc_long(j,i)=0.0D0
16894             gradb(j,i)=0.0d0
16895             gradbx(j,i)=0.0d0
16896             gvdwpp(j,i)=0.0d0
16897             gel_loc(j,i)=0.0d0
16898             gel_loc_long(j,i)=0.0d0
16899             ghpbc(j,i)=0.0D0
16900             ghpbx(j,i)=0.0D0
16901             gcorr3_turn(j,i)=0.0d0
16902             gcorr4_turn(j,i)=0.0d0
16903             gradcorr(j,i)=0.0d0
16904             gradcorr_long(j,i)=0.0d0
16905             gradcorr5_long(j,i)=0.0d0
16906             gradcorr6_long(j,i)=0.0d0
16907             gcorr6_turn_long(j,i)=0.0d0
16908             gradcorr5(j,i)=0.0d0
16909             gradcorr6(j,i)=0.0d0
16910             gcorr6_turn(j,i)=0.0d0
16911             gsccorc(j,i)=0.0d0
16912             gsccorx(j,i)=0.0d0
16913             gradc(j,i,icg)=0.0d0
16914             gradx(j,i,icg)=0.0d0
16915             gscloc(j,i)=0.0d0
16916             gsclocx(j,i)=0.0d0
16917             gliptran(j,i)=0.0d0
16918             gliptranx(j,i)=0.0d0
16919             gliptranc(j,i)=0.0d0
16920             gshieldx(j,i)=0.0d0
16921             gshieldc(j,i)=0.0d0
16922             gshieldc_loc(j,i)=0.0d0
16923             gshieldx_ec(j,i)=0.0d0
16924             gshieldc_ec(j,i)=0.0d0
16925             gshieldc_loc_ec(j,i)=0.0d0
16926             gshieldx_t3(j,i)=0.0d0
16927             gshieldc_t3(j,i)=0.0d0
16928             gshieldc_loc_t3(j,i)=0.0d0
16929             gshieldx_t4(j,i)=0.0d0
16930             gshieldc_t4(j,i)=0.0d0
16931             gshieldc_loc_t4(j,i)=0.0d0
16932             gshieldx_ll(j,i)=0.0d0
16933             gshieldc_ll(j,i)=0.0d0
16934             gshieldc_loc_ll(j,i)=0.0d0
16935             gg_tube(j,i)=0.0d0
16936             gg_tube_sc(j,i)=0.0d0
16937             gradafm(j,i)=0.0d0
16938             gradb_nucl(j,i)=0.0d0
16939             gradbx_nucl(j,i)=0.0d0
16940             gvdwpp_nucl(j,i)=0.0d0
16941             gvdwpp(j,i)=0.0d0
16942             gelpp(j,i)=0.0d0
16943             gvdwpsb(j,i)=0.0d0
16944             gvdwpsb1(j,i)=0.0d0
16945             gvdwsbc(j,i)=0.0d0
16946             gvdwsbx(j,i)=0.0d0
16947             gelsbc(j,i)=0.0d0
16948             gradcorr_nucl(j,i)=0.0d0
16949             gradcorr3_nucl(j,i)=0.0d0
16950             gradxorr_nucl(j,i)=0.0d0
16951             gradxorr3_nucl(j,i)=0.0d0
16952             gelsbx(j,i)=0.0d0
16953             gsbloc(j,i)=0.0d0
16954             gsblocx(j,i)=0.0d0
16955             gradpepcat(j,i)=0.0d0
16956             gradpepcatx(j,i)=0.0d0
16957             gradcatcat(j,i)=0.0d0
16958             gvdwx_scbase(j,i)=0.0d0
16959             gvdwc_scbase(j,i)=0.0d0
16960             gvdwx_pepbase(j,i)=0.0d0
16961             gvdwc_pepbase(j,i)=0.0d0
16962             gvdwx_scpho(j,i)=0.0d0
16963             gvdwc_scpho(j,i)=0.0d0
16964             gvdwc_peppho(j,i)=0.0d0
16965             gradnuclcatx(j,i)=0.0d0
16966             gradnuclcat(j,i)=0.0d0
16967           enddo
16968            enddo
16969           do i=0,nres
16970           do j=1,3
16971             do intertyp=1,3
16972              gloc_sc(intertyp,i,icg)=0.0d0
16973             enddo
16974           enddo
16975           enddo
16976           do i=1,nres
16977            do j=1,maxcontsshi
16978            shield_list(j,i)=0
16979           do k=1,3
16980       !C           print *,i,j,k
16981              grad_shield_side(k,j,i)=0.0d0
16982              grad_shield_loc(k,j,i)=0.0d0
16983            enddo
16984            enddo
16985            ishield_list(i)=0
16986           enddo
16987
16988       !
16989       ! Initialize the gradient of local energy terms.
16990       !
16991       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16992       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16993       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16994       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16995       !      allocate(gel_loc_turn3(nres))
16996       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16997       !      allocate(gsccor_loc(nres))      !(maxres)
16998
16999           do i=1,4*nres
17000           gloc(i,icg)=0.0D0
17001           enddo
17002           do i=1,nres
17003           gel_loc_loc(i)=0.0d0
17004           gcorr_loc(i)=0.0d0
17005           g_corr5_loc(i)=0.0d0
17006           g_corr6_loc(i)=0.0d0
17007           gel_loc_turn3(i)=0.0d0
17008           gel_loc_turn4(i)=0.0d0
17009           gel_loc_turn6(i)=0.0d0
17010           gsccor_loc(i)=0.0d0
17011           enddo
17012       ! initialize gcart and gxcart
17013       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17014           do i=0,nres
17015           do j=1,3
17016             gcart(j,i)=0.0d0
17017             gxcart(j,i)=0.0d0
17018           enddo
17019           enddo
17020           return
17021           end subroutine zerograd
17022       !-----------------------------------------------------------------------------
17023           real(kind=8) function fdum()
17024           fdum=0.0D0
17025           return
17026           end function fdum
17027       !-----------------------------------------------------------------------------
17028       ! intcartderiv.F
17029       !-----------------------------------------------------------------------------
17030           subroutine intcartderiv
17031       !      implicit real*8 (a-h,o-z)
17032       !      include 'DIMENSIONS'
17033 #ifdef MPI
17034           include 'mpif.h'
17035 #endif
17036       !      include 'COMMON.SETUP'
17037       !      include 'COMMON.CHAIN'
17038       !      include 'COMMON.VAR'
17039       !      include 'COMMON.GEO'
17040       !      include 'COMMON.INTERACT'
17041       !      include 'COMMON.DERIV'
17042       !      include 'COMMON.IOUNITS'
17043       !      include 'COMMON.LOCAL'
17044       !      include 'COMMON.SCCOR'
17045           real(kind=8) :: pi4,pi34
17046           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17047           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17048                   dcosomega,dsinomega !(3,3,maxres)
17049           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17050
17051           integer :: i,j,k
17052           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17053                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17054                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17055                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17056           integer :: nres2
17057           nres2=2*nres
17058
17059       !el from module energy-------------
17060       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17061       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17062       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17063
17064       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17065       !el      allocate(dsintau(3,3,3,0:nres2))
17066       !el      allocate(dtauangle(3,3,3,0:nres2))
17067       !el      allocate(domicron(3,2,2,0:nres2))
17068       !el      allocate(dcosomicron(3,2,2,0:nres2))
17069
17070
17071
17072 #if defined(MPI) && defined(PARINTDER)
17073           if (nfgtasks.gt.1 .and. me.eq.king) &
17074           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17075 #endif
17076           pi4 = 0.5d0*pipol
17077           pi34 = 3*pi4
17078
17079       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17080       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17081
17082       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17083           do i=1,nres
17084           do j=1,3
17085             dtheta(j,1,i)=0.0d0
17086             dtheta(j,2,i)=0.0d0
17087             dphi(j,1,i)=0.0d0
17088             dphi(j,2,i)=0.0d0
17089             dphi(j,3,i)=0.0d0
17090             dcosomicron(j,1,1,i)=0.0d0
17091             dcosomicron(j,1,2,i)=0.0d0
17092             dcosomicron(j,2,1,i)=0.0d0
17093             dcosomicron(j,2,2,i)=0.0d0
17094           enddo
17095           enddo
17096       ! Derivatives of theta's
17097 #if defined(MPI) && defined(PARINTDER)
17098       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17099           do i=max0(ithet_start-1,3),ithet_end
17100 #else
17101           do i=3,nres
17102 #endif
17103           cost=dcos(theta(i))
17104           sint=sqrt(1-cost*cost)
17105           do j=1,3
17106             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17107             vbld(i-1)
17108             if (((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))) &
17109              dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17110             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17111             vbld(i)
17112             if ((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))&
17113              dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17114           enddo
17115           enddo
17116 #if defined(MPI) && defined(PARINTDER)
17117       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17118           do i=max0(ithet_start-1,3),ithet_end
17119 #else
17120           do i=3,nres
17121 #endif
17122           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17123           cost1=dcos(omicron(1,i))
17124           sint1=sqrt(1-cost1*cost1)
17125           cost2=dcos(omicron(2,i))
17126           sint2=sqrt(1-cost2*cost2)
17127            do j=1,3
17128       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17129             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17130             cost1*dc_norm(j,i-2))/ &
17131             vbld(i-1)
17132             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17133             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17134             +cost1*(dc_norm(j,i-1+nres)))/ &
17135             vbld(i-1+nres)
17136             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17137       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17138       !C Looks messy but better than if in loop
17139             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17140             +cost2*dc_norm(j,i-1))/ &
17141             vbld(i)
17142             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17143             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17144              +cost2*(-dc_norm(j,i-1+nres)))/ &
17145             vbld(i-1+nres)
17146       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17147             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17148           enddo
17149            endif
17150           enddo
17151       !elwrite(iout,*) "after vbld write"
17152       ! Derivatives of phi:
17153       ! If phi is 0 or 180 degrees, then the formulas
17154       ! have to be derived by power series expansion of the
17155       ! conventional formulas around 0 and 180.
17156 #ifdef PARINTDER
17157           do i=iphi1_start,iphi1_end
17158 #else
17159           do i=4,nres
17160 #endif
17161       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17162       ! the conventional case
17163           sint=dsin(theta(i))
17164           sint1=dsin(theta(i-1))
17165           sing=dsin(phi(i))
17166           cost=dcos(theta(i))
17167           cost1=dcos(theta(i-1))
17168           cosg=dcos(phi(i))
17169           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17170           if ((sint*sint1).eq.0.0d0) then
17171           fac0=0.0d0
17172           else
17173           fac0=1.0d0/(sint1*sint)
17174           endif
17175           fac1=cost*fac0
17176           fac2=cost1*fac0
17177           if (sint1.ne.0.0d0) then
17178           fac3=cosg*cost1/(sint1*sint1)
17179           else
17180           fac3=0.0d0
17181           endif
17182           if (sint.ne.0.0d0) then
17183           fac4=cosg*cost/(sint*sint)
17184           else
17185           fac4=0.0d0
17186           endif
17187       !    Obtaining the gamma derivatives from sine derivative
17188            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17189              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17190              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17191            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17192            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17193            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17194            do j=1,3
17195             if (sint.ne.0.0d0) then
17196             ctgt=cost/sint
17197             else
17198             ctgt=0.0d0
17199             endif
17200             if (sint1.ne.0.0d0) then
17201             ctgt1=cost1/sint1
17202             else
17203             ctgt1=0.0d0
17204             endif
17205             cosg_inv=1.0d0/cosg
17206             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17207             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17208               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17209             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17210             dsinphi(j,2,i)= &
17211               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17212               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17213             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17214             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17215               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17216       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17217             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17218             endif
17219 !             write(iout,*) "just after,close to pi",dphi(j,3,i),&
17220 !              sing*(ctgt1*dtheta(j,2,i-1)),ctgt*dtheta(j,1,i), &
17221 !              (fac0*vp2(j)+sing*dc_norm(j,i-2)),vbld_inv(i-1)
17222
17223       ! Bug fixed 3/24/05 (AL)
17224            enddo
17225       !   Obtaining the gamma derivatives from cosine derivative
17226           else
17227              do j=1,3
17228              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17229              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17230              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17231              dc_norm(j,i-3))/vbld(i-2)
17232              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17233              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17234              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17235              dcostheta(j,1,i)
17236              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17237              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17238              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17239              dc_norm(j,i-1))/vbld(i)
17240              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17241 !#define DEBUG
17242 #ifdef DEBUG
17243              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17244 #endif
17245 !#undef DEBUG
17246              endif
17247            enddo
17248           endif
17249           enddo
17250       !alculate derivative of Tauangle
17251 #ifdef PARINTDER
17252           do i=itau_start,itau_end
17253 #else
17254           do i=3,nres
17255       !elwrite(iout,*) " vecpr",i,nres
17256 #endif
17257            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17258       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17259       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17260       !c dtauangle(j,intertyp,dervityp,residue number)
17261       !c INTERTYP=1 SC...Ca...Ca..Ca
17262       ! the conventional case
17263           sint=dsin(theta(i))
17264           sint1=dsin(omicron(2,i-1))
17265           sing=dsin(tauangle(1,i))
17266           cost=dcos(theta(i))
17267           cost1=dcos(omicron(2,i-1))
17268           cosg=dcos(tauangle(1,i))
17269       !elwrite(iout,*) " vecpr5",i,nres
17270           do j=1,3
17271       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17272       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17273           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17274       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17275           enddo
17276           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17277       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac
17278         if ((sint*sint1).eq.0.0d0) then
17279           fac0=0.0d0
17280           else
17281           fac0=1.0d0/(sint1*sint)
17282           endif
17283           fac1=cost*fac0
17284           fac2=cost1*fac0
17285           if (sint1.ne.0.0d0) then
17286           fac3=cosg*cost1/(sint1*sint1)
17287           else
17288           fac3=0.0d0
17289           endif
17290           if (sint.ne.0.0d0) then
17291           fac4=cosg*cost/(sint*sint)
17292           else
17293           fac4=0.0d0
17294           endif
17295
17296       !    Obtaining the gamma derivatives from sine derivative
17297            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17298              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17299              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17300            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17301            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17302            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17303           do j=1,3
17304             ctgt=cost/sint
17305             ctgt1=cost1/sint1
17306             cosg_inv=1.0d0/cosg
17307             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17308            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17309            *vbld_inv(i-2+nres)
17310             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17311             dsintau(j,1,2,i)= &
17312               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17313               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17314       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17315             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17316       ! Bug fixed 3/24/05 (AL)
17317             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17318               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17319       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17320             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17321            enddo
17322       !   Obtaining the gamma derivatives from cosine derivative
17323           else
17324              do j=1,3
17325              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17326              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17327              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17328              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17329              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17330              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17331              dcostheta(j,1,i)
17332              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17333              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17334              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17335              dc_norm(j,i-1))/vbld(i)
17336              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17337       !         write (iout,*) "else",i
17338            enddo
17339           endif
17340       !        do k=1,3
17341       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17342       !        enddo
17343           enddo
17344       !C Second case Ca...Ca...Ca...SC
17345 #ifdef PARINTDER
17346           do i=itau_start,itau_end
17347 #else
17348           do i=4,nres
17349 #endif
17350            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17351             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17352       ! the conventional case
17353           sint=dsin(omicron(1,i))
17354           sint1=dsin(theta(i-1))
17355           sing=dsin(tauangle(2,i))
17356           cost=dcos(omicron(1,i))
17357           cost1=dcos(theta(i-1))
17358           cosg=dcos(tauangle(2,i))
17359       !        do j=1,3
17360       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17361       !        enddo
17362           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17363         if ((sint*sint1).eq.0.0d0) then
17364           fac0=0.0d0
17365           else
17366           fac0=1.0d0/(sint1*sint)
17367           endif
17368           fac1=cost*fac0
17369           fac2=cost1*fac0
17370           if (sint1.ne.0.0d0) then
17371           fac3=cosg*cost1/(sint1*sint1)
17372           else
17373           fac3=0.0d0
17374           endif
17375           if (sint.ne.0.0d0) then
17376           fac4=cosg*cost/(sint*sint)
17377           else
17378           fac4=0.0d0
17379           endif
17380       !    Obtaining the gamma derivatives from sine derivative
17381            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17382              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17383              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17384            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17385            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17386            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17387           do j=1,3
17388             ctgt=cost/sint
17389             ctgt1=cost1/sint1
17390             cosg_inv=1.0d0/cosg
17391             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17392               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17393       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17394       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17395             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17396             dsintau(j,2,2,i)= &
17397               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17398               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17399       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17400       !     & sing*ctgt*domicron(j,1,2,i),
17401       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17402             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17403       ! Bug fixed 3/24/05 (AL)
17404             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17405              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17406       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17407             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17408            enddo
17409       !   Obtaining the gamma derivatives from cosine derivative
17410           else
17411              do j=1,3
17412              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17413              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17414              dc_norm(j,i-3))/vbld(i-2)
17415              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17416              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17417              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17418              dcosomicron(j,1,1,i)
17419              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17420              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17421              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17422              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17423              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17424       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17425            enddo
17426           endif
17427           enddo
17428
17429       !CC third case SC...Ca...Ca...SC
17430 #ifdef PARINTDER
17431
17432           do i=itau_start,itau_end
17433 #else
17434           do i=3,nres
17435 #endif
17436       ! the conventional case
17437           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17438           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17439           sint=dsin(omicron(1,i))
17440           sint1=dsin(omicron(2,i-1))
17441           sing=dsin(tauangle(3,i))
17442           cost=dcos(omicron(1,i))
17443           cost1=dcos(omicron(2,i-1))
17444           cosg=dcos(tauangle(3,i))
17445           do j=1,3
17446           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17447       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17448           enddo
17449           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17450         if ((sint*sint1).eq.0.0d0) then
17451           fac0=0.0d0
17452           else
17453           fac0=1.0d0/(sint1*sint)
17454           endif
17455           fac1=cost*fac0
17456           fac2=cost1*fac0
17457           if (sint1.ne.0.0d0) then
17458           fac3=cosg*cost1/(sint1*sint1)
17459           else
17460           fac3=0.0d0
17461           endif
17462           if (sint.ne.0.0d0) then
17463           fac4=cosg*cost/(sint*sint)
17464           else
17465           fac4=0.0d0
17466           endif
17467       !    Obtaining the gamma derivatives from sine derivative
17468            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17469              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17470              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17471            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17472            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17473            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17474           do j=1,3
17475             ctgt=cost/sint
17476             ctgt1=cost1/sint1
17477             cosg_inv=1.0d0/cosg
17478             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17479               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17480               *vbld_inv(i-2+nres)
17481             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17482             dsintau(j,3,2,i)= &
17483               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17484               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17485             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17486       ! Bug fixed 3/24/05 (AL)
17487             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17488               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17489               *vbld_inv(i-1+nres)
17490       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17491             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17492            enddo
17493       !   Obtaining the gamma derivatives from cosine derivative
17494           else
17495              do j=1,3
17496              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17497              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17498              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17499              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17500              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17501              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17502              dcosomicron(j,1,1,i)
17503              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17504              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17505              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17506              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17507              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17508       !          write(iout,*) "else",i
17509            enddo
17510           endif
17511           enddo
17512
17513 #ifdef CRYST_SC
17514       !   Derivatives of side-chain angles alpha and omega
17515 #if defined(MPI) && defined(PARINTDER)
17516           do i=ibond_start,ibond_end
17517 #else
17518           do i=2,nres-1
17519 #endif
17520             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17521              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17522              fac6=fac5/vbld(i)
17523              fac7=fac5*fac5
17524              fac8=fac5/vbld(i+1)
17525              fac9=fac5/vbld(i+nres)
17526              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17527              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17528              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17529              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17530              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17531              sina=sqrt(1-cosa*cosa)
17532              sino=dsin(omeg(i))
17533       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17534              do j=1,3
17535               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17536               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17537               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17538               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17539               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17540               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17541               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17542               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17543               vbld(i+nres))
17544               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17545             enddo
17546       ! obtaining the derivatives of omega from sines
17547             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17548                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17549                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17550                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17551                dsin(theta(i+1)))
17552                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17553                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17554                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17555                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17556                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17557                coso_inv=1.0d0/dcos(omeg(i))
17558                do j=1,3
17559                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17560                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17561                (sino*dc_norm(j,i-1))/vbld(i)
17562                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17563                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17564                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17565                -sino*dc_norm(j,i)/vbld(i+1)
17566                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17567                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17568                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17569                vbld(i+nres)
17570                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17571               enddo
17572              else
17573       !   obtaining the derivatives of omega from cosines
17574              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17575              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17576              fac12=fac10*sina
17577              fac13=fac12*fac12
17578              fac14=sina*sina
17579              do j=1,3
17580               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17581               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17582               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17583               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17584               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17585               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17586               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17587               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17588               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17589               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17590               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17591               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17592               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17593               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17594               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17595             enddo
17596             endif
17597            else
17598              do j=1,3
17599              do k=1,3
17600                dalpha(k,j,i)=0.0d0
17601                domega(k,j,i)=0.0d0
17602              enddo
17603              enddo
17604            endif
17605            enddo
17606 #endif
17607 #if defined(MPI) && defined(PARINTDER)
17608           if (nfgtasks.gt.1) then
17609 #ifdef DEBUG
17610       !d      write (iout,*) "Gather dtheta"
17611       !d      call flush(iout)
17612           write (iout,*) "dtheta before gather"
17613           do i=1,nres
17614           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17615           enddo
17616 #endif
17617           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17618           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17619           king,FG_COMM,IERROR)
17620 !#define DEBUG
17621 #ifdef DEBUG
17622       !d      write (iout,*) "Gather dphi"
17623       !d      call flush(iout)
17624           write (iout,*) "dphi before gather"
17625           do i=1,nres
17626           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17627           enddo
17628 #endif
17629 !#undef DEBUG
17630           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17631           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17632           king,FG_COMM,IERROR)
17633       !d      write (iout,*) "Gather dalpha"
17634       !d      call flush(iout)
17635 #ifdef CRYST_SC
17636           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17637           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17638           king,FG_COMM,IERROR)
17639       !d      write (iout,*) "Gather domega"
17640       !d      call flush(iout)
17641           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17642           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17643           king,FG_COMM,IERROR)
17644 #endif
17645           endif
17646 #endif
17647 !#define DEBUG
17648 #ifdef DEBUG
17649           write (iout,*) "dtheta after gather"
17650           do i=1,nres
17651           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17652           enddo
17653           write (iout,*) "dphi after gather"
17654           do i=1,nres
17655           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17656           enddo
17657           write (iout,*) "dalpha after gather"
17658           do i=1,nres
17659           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17660           enddo
17661           write (iout,*) "domega after gather"
17662           do i=1,nres
17663           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17664           enddo
17665 #endif
17666 !#undef DEBUG
17667           return
17668           end subroutine intcartderiv
17669       !-----------------------------------------------------------------------------
17670           subroutine checkintcartgrad
17671       !      implicit real*8 (a-h,o-z)
17672       !      include 'DIMENSIONS'
17673 #ifdef MPI
17674           include 'mpif.h'
17675 #endif
17676       !      include 'COMMON.CHAIN'
17677       !      include 'COMMON.VAR'
17678       !      include 'COMMON.GEO'
17679       !      include 'COMMON.INTERACT'
17680       !      include 'COMMON.DERIV'
17681       !      include 'COMMON.IOUNITS'
17682       !      include 'COMMON.SETUP'
17683           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17684           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17685           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17686           real(kind=8),dimension(3) :: dc_norm_s
17687           real(kind=8) :: aincr=1.0d-5
17688           integer :: i,j
17689           real(kind=8) :: dcji
17690           do i=1,nres
17691           phi_s(i)=phi(i)
17692           theta_s(i)=theta(i)
17693           alph_s(i)=alph(i)
17694           omeg_s(i)=omeg(i)
17695           enddo
17696       ! Check theta gradient
17697           write (iout,*) &
17698            "Analytical (upper) and numerical (lower) gradient of theta"
17699           write (iout,*)
17700           do i=3,nres
17701           do j=1,3
17702             dcji=dc(j,i-2)
17703             dc(j,i-2)=dcji+aincr
17704             call chainbuild_cart
17705             call int_from_cart1(.false.)
17706         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17707         dc(j,i-2)=dcji
17708         dcji=dc(j,i-1)
17709         dc(j,i-1)=dc(j,i-1)+aincr
17710         call chainbuild_cart
17711         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17712         dc(j,i-1)=dcji
17713       enddo
17714 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17715 !el          (dtheta(j,2,i),j=1,3)
17716 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17717 !el          (dthetanum(j,2,i),j=1,3)
17718 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17719 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17720 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17721 !el        write (iout,*)
17722       enddo
17723 ! Check gamma gradient
17724       write (iout,*) &
17725        "Analytical (upper) and numerical (lower) gradient of gamma"
17726       do i=4,nres
17727       do j=1,3
17728         dcji=dc(j,i-3)
17729         dc(j,i-3)=dcji+aincr
17730         call chainbuild_cart
17731         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17732             dc(j,i-3)=dcji
17733         dcji=dc(j,i-2)
17734         dc(j,i-2)=dcji+aincr
17735         call chainbuild_cart
17736         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17737         dc(j,i-2)=dcji
17738         dcji=dc(j,i-1)
17739         dc(j,i-1)=dc(j,i-1)+aincr
17740         call chainbuild_cart
17741         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17742         dc(j,i-1)=dcji
17743       enddo
17744 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17745 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17746 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17747 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17748 !el        write (iout,'(5x,3(3f10.5,5x))') &
17749 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17750 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17751 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17752 !el        write (iout,*)
17753       enddo
17754 ! Check alpha gradient
17755       write (iout,*) &
17756        "Analytical (upper) and numerical (lower) gradient of alpha"
17757       do i=2,nres-1
17758        if(itype(i,1).ne.10) then
17759              do j=1,3
17760               dcji=dc(j,i-1)
17761                dc(j,i-1)=dcji+aincr
17762             call chainbuild_cart
17763             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17764              /aincr
17765               dc(j,i-1)=dcji
17766             dcji=dc(j,i)
17767             dc(j,i)=dcji+aincr
17768             call chainbuild_cart
17769             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17770              /aincr
17771             dc(j,i)=dcji
17772             dcji=dc(j,i+nres)
17773             dc(j,i+nres)=dc(j,i+nres)+aincr
17774             call chainbuild_cart
17775             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17776              /aincr
17777            dc(j,i+nres)=dcji
17778           enddo
17779         endif
17780 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17781 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17782 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17783 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17784 !el        write (iout,'(5x,3(3f10.5,5x))') &
17785 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17786 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17787 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17788 !el        write (iout,*)
17789       enddo
17790 !     Check omega gradient
17791       write (iout,*) &
17792        "Analytical (upper) and numerical (lower) gradient of omega"
17793       do i=2,nres-1
17794        if(itype(i,1).ne.10) then
17795              do j=1,3
17796               dcji=dc(j,i-1)
17797                dc(j,i-1)=dcji+aincr
17798             call chainbuild_cart
17799             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17800              /aincr
17801               dc(j,i-1)=dcji
17802             dcji=dc(j,i)
17803             dc(j,i)=dcji+aincr
17804             call chainbuild_cart
17805             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17806              /aincr
17807             dc(j,i)=dcji
17808             dcji=dc(j,i+nres)
17809             dc(j,i+nres)=dc(j,i+nres)+aincr
17810             call chainbuild_cart
17811             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17812              /aincr
17813            dc(j,i+nres)=dcji
17814           enddo
17815         endif
17816 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17817 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17818 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17819 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17820 !el        write (iout,'(5x,3(3f10.5,5x))') &
17821 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17822 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17823 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17824 !el        write (iout,*)
17825       enddo
17826       return
17827       end subroutine checkintcartgrad
17828 !-----------------------------------------------------------------------------
17829 ! q_measure.F
17830 !-----------------------------------------------------------------------------
17831       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17832 !      implicit real*8 (a-h,o-z)
17833 !      include 'DIMENSIONS'
17834 !      include 'COMMON.IOUNITS'
17835 !      include 'COMMON.CHAIN'
17836 !      include 'COMMON.INTERACT'
17837 !      include 'COMMON.VAR'
17838       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17839       integer :: kkk,nsep=3
17840       real(kind=8) :: qm      !dist,
17841       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17842       logical :: lprn=.false.
17843       logical :: flag
17844 !      real(kind=8) :: sigm,x
17845
17846 !el      sigm(x)=0.25d0*x     ! local function
17847       qqmax=1.0d10
17848       do kkk=1,nperm
17849       qq = 0.0d0
17850       nl=0
17851        if(flag) then
17852       do il=seg1+nsep,seg2
17853         do jl=seg1,il-nsep
17854           nl=nl+1
17855           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17856                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17857                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17858           dij=dist(il,jl)
17859           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17860           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17861             nl=nl+1
17862             d0ijCM=dsqrt( &
17863                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17864                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17865                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17866             dijCM=dist(il+nres,jl+nres)
17867             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17868           endif
17869           qq = qq+qqij+qqijCM
17870         enddo
17871       enddo
17872       qq = qq/nl
17873       else
17874       do il=seg1,seg2
17875       if((seg3-il).lt.3) then
17876            secseg=il+3
17877       else
17878            secseg=seg3
17879       endif
17880         do jl=secseg,seg4
17881           nl=nl+1
17882           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17883                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17884                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17885           dij=dist(il,jl)
17886           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17887           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17888             nl=nl+1
17889             d0ijCM=dsqrt( &
17890                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17891                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17892                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17893             dijCM=dist(il+nres,jl+nres)
17894             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17895           endif
17896           qq = qq+qqij+qqijCM
17897         enddo
17898       enddo
17899       qq = qq/nl
17900       endif
17901       if (qqmax.le.qq) qqmax=qq
17902       enddo
17903       qwolynes=1.0d0-qqmax
17904       return
17905       end function qwolynes
17906 !-----------------------------------------------------------------------------
17907       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17908 !      implicit real*8 (a-h,o-z)
17909 !      include 'DIMENSIONS'
17910 !      include 'COMMON.IOUNITS'
17911 !      include 'COMMON.CHAIN'
17912 !      include 'COMMON.INTERACT'
17913 !      include 'COMMON.VAR'
17914 !      include 'COMMON.MD'
17915       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17916       integer :: nsep=3, kkk
17917 !el      real(kind=8) :: dist
17918       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17919       logical :: lprn=.false.
17920       logical :: flag
17921       real(kind=8) :: sim,dd0,fac,ddqij
17922 !el      sigm(x)=0.25d0*x           ! local function
17923       do kkk=1,nperm
17924       do i=0,nres
17925       do j=1,3
17926         dqwol(j,i)=0.0d0
17927         dxqwol(j,i)=0.0d0
17928       enddo
17929       enddo
17930       nl=0
17931        if(flag) then
17932       do il=seg1+nsep,seg2
17933         do jl=seg1,il-nsep
17934           nl=nl+1
17935           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17936                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17937                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17938           dij=dist(il,jl)
17939           sim = 1.0d0/sigm(d0ij)
17940           sim = sim*sim
17941           dd0 = dij-d0ij
17942           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17943         do k=1,3
17944             ddqij = (c(k,il)-c(k,jl))*fac
17945             dqwol(k,il)=dqwol(k,il)+ddqij
17946             dqwol(k,jl)=dqwol(k,jl)-ddqij
17947           enddo
17948
17949           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17950             nl=nl+1
17951             d0ijCM=dsqrt( &
17952                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17953                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17954                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17955             dijCM=dist(il+nres,jl+nres)
17956             sim = 1.0d0/sigm(d0ijCM)
17957             sim = sim*sim
17958             dd0=dijCM-d0ijCM
17959             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17960             do k=1,3
17961             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17962             dxqwol(k,il)=dxqwol(k,il)+ddqij
17963             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17964             enddo
17965           endif
17966         enddo
17967       enddo
17968        else
17969       do il=seg1,seg2
17970       if((seg3-il).lt.3) then
17971            secseg=il+3
17972       else
17973            secseg=seg3
17974       endif
17975         do jl=secseg,seg4
17976           nl=nl+1
17977           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17978                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17979                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17980           dij=dist(il,jl)
17981           sim = 1.0d0/sigm(d0ij)
17982           sim = sim*sim
17983           dd0 = dij-d0ij
17984           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17985           do k=1,3
17986             ddqij = (c(k,il)-c(k,jl))*fac
17987             dqwol(k,il)=dqwol(k,il)+ddqij
17988             dqwol(k,jl)=dqwol(k,jl)-ddqij
17989           enddo
17990           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17991             nl=nl+1
17992             d0ijCM=dsqrt( &
17993                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17994                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17995                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17996             dijCM=dist(il+nres,jl+nres)
17997             sim = 1.0d0/sigm(d0ijCM)
17998             sim=sim*sim
17999             dd0 = dijCM-d0ijCM
18000             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18001             do k=1,3
18002              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18003              dxqwol(k,il)=dxqwol(k,il)+ddqij
18004              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18005             enddo
18006           endif
18007         enddo
18008       enddo
18009       endif
18010       enddo
18011        do i=0,nres
18012        do j=1,3
18013          dqwol(j,i)=dqwol(j,i)/nl
18014          dxqwol(j,i)=dxqwol(j,i)/nl
18015        enddo
18016        enddo
18017       return
18018       end subroutine qwolynes_prim
18019 !-----------------------------------------------------------------------------
18020       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18021 !      implicit real*8 (a-h,o-z)
18022 !      include 'DIMENSIONS'
18023 !      include 'COMMON.IOUNITS'
18024 !      include 'COMMON.CHAIN'
18025 !      include 'COMMON.INTERACT'
18026 !      include 'COMMON.VAR'
18027       integer :: seg1,seg2,seg3,seg4
18028       logical :: flag
18029       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18030       real(kind=8),dimension(3,0:2*nres) :: cdummy
18031       real(kind=8) :: q1,q2
18032       real(kind=8) :: delta=1.0d-10
18033       integer :: i,j
18034
18035       do i=0,nres
18036       do j=1,3
18037         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18038         cdummy(j,i)=c(j,i)
18039         c(j,i)=c(j,i)+delta
18040         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18041         qwolan(j,i)=(q2-q1)/delta
18042         c(j,i)=cdummy(j,i)
18043       enddo
18044       enddo
18045       do i=0,nres
18046       do j=1,3
18047         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18048         cdummy(j,i+nres)=c(j,i+nres)
18049         c(j,i+nres)=c(j,i+nres)+delta
18050         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18051         qwolxan(j,i)=(q2-q1)/delta
18052         c(j,i+nres)=cdummy(j,i+nres)
18053       enddo
18054       enddo
18055 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18056 !      do i=0,nct
18057 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18058 !      enddo
18059 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18060 !      do i=0,nct
18061 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18062 !      enddo
18063       return
18064       end subroutine qwol_num
18065 !-----------------------------------------------------------------------------
18066       subroutine EconstrQ
18067 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18068 !      implicit real*8 (a-h,o-z)
18069 !      include 'DIMENSIONS'
18070 !      include 'COMMON.CONTROL'
18071 !      include 'COMMON.VAR'
18072 !      include 'COMMON.MD'
18073       use MD_data
18074 !#ifndef LANG0
18075 !      include 'COMMON.LANGEVIN'
18076 !#else
18077 !      include 'COMMON.LANGEVIN.lang0'
18078 !#endif
18079 !      include 'COMMON.CHAIN'
18080 !      include 'COMMON.DERIV'
18081 !      include 'COMMON.GEO'
18082 !      include 'COMMON.LOCAL'
18083 !      include 'COMMON.INTERACT'
18084 !      include 'COMMON.IOUNITS'
18085 !      include 'COMMON.NAMES'
18086 !      include 'COMMON.TIME1'
18087       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18088       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18089                duconst,duxconst
18090       integer :: kstart,kend,lstart,lend,idummy
18091       real(kind=8) :: delta=1.0d-7
18092       integer :: i,j,k,ii
18093       do i=0,nres
18094        do j=1,3
18095           duconst(j,i)=0.0d0
18096           dudconst(j,i)=0.0d0
18097           duxconst(j,i)=0.0d0
18098           dudxconst(j,i)=0.0d0
18099        enddo
18100       enddo
18101       Uconst=0.0d0
18102       do i=1,nfrag
18103        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18104          idummy,idummy)
18105        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18106 ! Calculating the derivatives of Constraint energy with respect to Q
18107        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18108          qinfrag(i,iset))
18109 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18110 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18111 !         hmnum=(hm2-hm1)/delta
18112 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18113 !     &   qinfrag(i,iset))
18114 !         write(iout,*) "harmonicnum frag", hmnum
18115 ! Calculating the derivatives of Q with respect to cartesian coordinates
18116        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18117         idummy,idummy)
18118 !         write(iout,*) "dqwol "
18119 !         do ii=1,nres
18120 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18121 !         enddo
18122 !         write(iout,*) "dxqwol "
18123 !         do ii=1,nres
18124 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18125 !         enddo
18126 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18127 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18128 !     &  ,idummy,idummy)
18129 !  The gradients of Uconst in Cs
18130        do ii=0,nres
18131           do j=1,3
18132              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18133              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18134           enddo
18135        enddo
18136       enddo
18137       do i=1,npair
18138        kstart=ifrag(1,ipair(1,i,iset),iset)
18139        kend=ifrag(2,ipair(1,i,iset),iset)
18140        lstart=ifrag(1,ipair(2,i,iset),iset)
18141        lend=ifrag(2,ipair(2,i,iset),iset)
18142        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18143        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18144 !  Calculating dU/dQ
18145        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18146 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18147 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18148 !         hmnum=(hm2-hm1)/delta
18149 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18150 !     &   qinpair(i,iset))
18151 !         write(iout,*) "harmonicnum pair ", hmnum
18152 ! Calculating dQ/dXi
18153        call qwolynes_prim(kstart,kend,.false.,&
18154         lstart,lend)
18155 !         write(iout,*) "dqwol "
18156 !         do ii=1,nres
18157 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18158 !         enddo
18159 !         write(iout,*) "dxqwol "
18160 !         do ii=1,nres
18161 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18162 !        enddo
18163 ! Calculating numerical gradients
18164 !        call qwol_num(kstart,kend,.false.
18165 !     &  ,lstart,lend)
18166 ! The gradients of Uconst in Cs
18167        do ii=0,nres
18168           do j=1,3
18169              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18170              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18171           enddo
18172        enddo
18173       enddo
18174 !      write(iout,*) "Uconst inside subroutine ", Uconst
18175 ! Transforming the gradients from Cs to dCs for the backbone
18176       do i=0,nres
18177        do j=i+1,nres
18178          do k=1,3
18179            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18180          enddo
18181        enddo
18182       enddo
18183 !  Transforming the gradients from Cs to dCs for the side chains
18184       do i=1,nres
18185        do j=1,3
18186          dudxconst(j,i)=duxconst(j,i)
18187        enddo
18188       enddo
18189 !      write(iout,*) "dU/ddc backbone "
18190 !       do ii=0,nres
18191 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18192 !      enddo
18193 !      write(iout,*) "dU/ddX side chain "
18194 !      do ii=1,nres
18195 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18196 !      enddo
18197 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18198 !      call dEconstrQ_num
18199       return
18200       end subroutine EconstrQ
18201 !-----------------------------------------------------------------------------
18202       subroutine dEconstrQ_num
18203 ! Calculating numerical dUconst/ddc and dUconst/ddx
18204 !      implicit real*8 (a-h,o-z)
18205 !      include 'DIMENSIONS'
18206 !      include 'COMMON.CONTROL'
18207 !      include 'COMMON.VAR'
18208 !      include 'COMMON.MD'
18209       use MD_data
18210 !#ifndef LANG0
18211 !      include 'COMMON.LANGEVIN'
18212 !#else
18213 !      include 'COMMON.LANGEVIN.lang0'
18214 !#endif
18215 !      include 'COMMON.CHAIN'
18216 !      include 'COMMON.DERIV'
18217 !      include 'COMMON.GEO'
18218 !      include 'COMMON.LOCAL'
18219 !      include 'COMMON.INTERACT'
18220 !      include 'COMMON.IOUNITS'
18221 !      include 'COMMON.NAMES'
18222 !      include 'COMMON.TIME1'
18223       real(kind=8) :: uzap1,uzap2
18224       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18225       integer :: kstart,kend,lstart,lend,idummy
18226       real(kind=8) :: delta=1.0d-7
18227 !el local variables
18228       integer :: i,ii,j
18229 !     real(kind=8) ::
18230 !     For the backbone
18231       do i=0,nres-1
18232        do j=1,3
18233           dUcartan(j,i)=0.0d0
18234           cdummy(j,i)=dc(j,i)
18235           dc(j,i)=dc(j,i)+delta
18236           call chainbuild_cart
18237         uzap2=0.0d0
18238           do ii=1,nfrag
18239            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18240             idummy,idummy)
18241              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18242             qinfrag(ii,iset))
18243           enddo
18244           do ii=1,npair
18245              kstart=ifrag(1,ipair(1,ii,iset),iset)
18246              kend=ifrag(2,ipair(1,ii,iset),iset)
18247              lstart=ifrag(1,ipair(2,ii,iset),iset)
18248              lend=ifrag(2,ipair(2,ii,iset),iset)
18249              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18250              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18251              qinpair(ii,iset))
18252           enddo
18253           dc(j,i)=cdummy(j,i)
18254           call chainbuild_cart
18255           uzap1=0.0d0
18256            do ii=1,nfrag
18257            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18258             idummy,idummy)
18259              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18260             qinfrag(ii,iset))
18261           enddo
18262           do ii=1,npair
18263              kstart=ifrag(1,ipair(1,ii,iset),iset)
18264              kend=ifrag(2,ipair(1,ii,iset),iset)
18265              lstart=ifrag(1,ipair(2,ii,iset),iset)
18266              lend=ifrag(2,ipair(2,ii,iset),iset)
18267              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18268              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18269             qinpair(ii,iset))
18270           enddo
18271           ducartan(j,i)=(uzap2-uzap1)/(delta)
18272        enddo
18273       enddo
18274 ! Calculating numerical gradients for dU/ddx
18275       do i=0,nres-1
18276        duxcartan(j,i)=0.0d0
18277        do j=1,3
18278           cdummy(j,i)=dc(j,i+nres)
18279           dc(j,i+nres)=dc(j,i+nres)+delta
18280           call chainbuild_cart
18281         uzap2=0.0d0
18282           do ii=1,nfrag
18283            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18284             idummy,idummy)
18285              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18286             qinfrag(ii,iset))
18287           enddo
18288           do ii=1,npair
18289              kstart=ifrag(1,ipair(1,ii,iset),iset)
18290              kend=ifrag(2,ipair(1,ii,iset),iset)
18291              lstart=ifrag(1,ipair(2,ii,iset),iset)
18292              lend=ifrag(2,ipair(2,ii,iset),iset)
18293              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18294              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18295             qinpair(ii,iset))
18296           enddo
18297           dc(j,i+nres)=cdummy(j,i)
18298           call chainbuild_cart
18299           uzap1=0.0d0
18300            do ii=1,nfrag
18301              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18302             ifrag(2,ii,iset),.true.,idummy,idummy)
18303              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18304             qinfrag(ii,iset))
18305           enddo
18306           do ii=1,npair
18307              kstart=ifrag(1,ipair(1,ii,iset),iset)
18308              kend=ifrag(2,ipair(1,ii,iset),iset)
18309              lstart=ifrag(1,ipair(2,ii,iset),iset)
18310              lend=ifrag(2,ipair(2,ii,iset),iset)
18311              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18312              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18313             qinpair(ii,iset))
18314           enddo
18315           duxcartan(j,i)=(uzap2-uzap1)/(delta)
18316        enddo
18317       enddo
18318       write(iout,*) "Numerical dUconst/ddc backbone "
18319       do ii=0,nres
18320       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18321       enddo
18322 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18323 !      do ii=1,nres
18324 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18325 !      enddo
18326       return
18327       end subroutine dEconstrQ_num
18328 !-----------------------------------------------------------------------------
18329 ! ssMD.F
18330 !-----------------------------------------------------------------------------
18331       subroutine check_energies
18332
18333 !      use random, only: ran_number
18334
18335 !      implicit none
18336 !     Includes
18337 !      include 'DIMENSIONS'
18338 !      include 'COMMON.CHAIN'
18339 !      include 'COMMON.VAR'
18340 !      include 'COMMON.IOUNITS'
18341 !      include 'COMMON.SBRIDGE'
18342 !      include 'COMMON.LOCAL'
18343 !      include 'COMMON.GEO'
18344
18345 !     External functions
18346 !EL      double precision ran_number
18347 !EL      external ran_number
18348
18349 !     Local variables
18350       integer :: i,j,k,l,lmax,p,pmax
18351       real(kind=8) :: rmin,rmax
18352       real(kind=8) :: eij
18353
18354       real(kind=8) :: d
18355       real(kind=8) :: wi,rij,tj,pj
18356 !      return
18357
18358       i=5
18359       j=14
18360
18361       d=dsc(1)
18362       rmin=2.0D0
18363       rmax=12.0D0
18364
18365       lmax=10000
18366       pmax=1
18367
18368       do k=1,3
18369       c(k,i)=0.0D0
18370       c(k,j)=0.0D0
18371       c(k,nres+i)=0.0D0
18372       c(k,nres+j)=0.0D0
18373       enddo
18374
18375       do l=1,lmax
18376
18377 !t        wi=ran_number(0.0D0,pi)
18378 !        wi=ran_number(0.0D0,pi/6.0D0)
18379 !        wi=0.0D0
18380 !t        tj=ran_number(0.0D0,pi)
18381 !t        pj=ran_number(0.0D0,pi)
18382 !        pj=ran_number(0.0D0,pi/6.0D0)
18383 !        pj=0.0D0
18384
18385       do p=1,pmax
18386 !t           rij=ran_number(rmin,rmax)
18387
18388          c(1,j)=d*sin(pj)*cos(tj)
18389          c(2,j)=d*sin(pj)*sin(tj)
18390          c(3,j)=d*cos(pj)
18391
18392          c(3,nres+i)=-rij
18393
18394          c(1,i)=d*sin(wi)
18395          c(3,i)=-rij-d*cos(wi)
18396
18397          do k=1,3
18398             dc(k,nres+i)=c(k,nres+i)-c(k,i)
18399             dc_norm(k,nres+i)=dc(k,nres+i)/d
18400             dc(k,nres+j)=c(k,nres+j)-c(k,j)
18401             dc_norm(k,nres+j)=dc(k,nres+j)/d
18402          enddo
18403
18404          call dyn_ssbond_ene(i,j,eij)
18405       enddo
18406       enddo
18407       call exit(1)
18408       return
18409       end subroutine check_energies
18410 !-----------------------------------------------------------------------------
18411       subroutine dyn_ssbond_ene(resi,resj,eij)
18412 !      implicit none
18413 !      Includes
18414       use calc_data
18415       use comm_sschecks
18416 !      include 'DIMENSIONS'
18417 !      include 'COMMON.SBRIDGE'
18418 !      include 'COMMON.CHAIN'
18419 !      include 'COMMON.DERIV'
18420 !      include 'COMMON.LOCAL'
18421 !      include 'COMMON.INTERACT'
18422 !      include 'COMMON.VAR'
18423 !      include 'COMMON.IOUNITS'
18424 !      include 'COMMON.CALC'
18425 #ifndef CLUST
18426 #ifndef WHAM
18427        use MD_data
18428 !      include 'COMMON.MD'
18429 !      use MD, only: totT,t_bath
18430 #endif
18431 #endif
18432 !     External functions
18433 !EL      double precision h_base
18434 !EL      external h_base
18435
18436 !     Input arguments
18437       integer :: resi,resj
18438
18439 !     Output arguments
18440       real(kind=8) :: eij
18441
18442 !     Local variables
18443       logical :: havebond
18444       integer itypi,itypj
18445       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18446       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18447       real(kind=8),dimension(3) :: dcosom1,dcosom2
18448       real(kind=8) :: ed
18449       real(kind=8) :: pom1,pom2
18450       real(kind=8) :: ljA,ljB,ljXs
18451       real(kind=8),dimension(1:3) :: d_ljB
18452       real(kind=8) :: ssA,ssB,ssC,ssXs
18453       real(kind=8) :: ssxm,ljxm,ssm,ljm
18454       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18455       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18456       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18457 !-------FIRST METHOD
18458       real(kind=8) :: xm
18459       real(kind=8),dimension(1:3) :: d_xm
18460 !-------END FIRST METHOD
18461 !-------SECOND METHOD
18462 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18463 !-------END SECOND METHOD
18464
18465 !-------TESTING CODE
18466 !el      logical :: checkstop,transgrad
18467 !el      common /sschecks/ checkstop,transgrad
18468
18469       integer :: icheck,nicheck,jcheck,njcheck
18470       real(kind=8),dimension(-1:1) :: echeck
18471       real(kind=8) :: deps,ssx0,ljx0
18472 !-------END TESTING CODE
18473
18474       eij=0.0d0
18475       i=resi
18476       j=resj
18477
18478 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18479 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18480
18481       itypi=itype(i,1)
18482       dxi=dc_norm(1,nres+i)
18483       dyi=dc_norm(2,nres+i)
18484       dzi=dc_norm(3,nres+i)
18485       dsci_inv=vbld_inv(i+nres)
18486
18487       itypj=itype(j,1)
18488       xj=c(1,nres+j)-c(1,nres+i)
18489       yj=c(2,nres+j)-c(2,nres+i)
18490       zj=c(3,nres+j)-c(3,nres+i)
18491       dxj=dc_norm(1,nres+j)
18492       dyj=dc_norm(2,nres+j)
18493       dzj=dc_norm(3,nres+j)
18494       dscj_inv=vbld_inv(j+nres)
18495
18496       chi1=chi(itypi,itypj)
18497       chi2=chi(itypj,itypi)
18498       chi12=chi1*chi2
18499       chip1=chip(itypi)
18500       chip2=chip(itypj)
18501       chip12=chip1*chip2
18502       alf1=alp(itypi)
18503       alf2=alp(itypj)
18504       alf12=0.5D0*(alf1+alf2)
18505
18506       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18507       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18508 !     The following are set in sc_angular
18509 !      erij(1)=xj*rij
18510 !      erij(2)=yj*rij
18511 !      erij(3)=zj*rij
18512 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18513 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18514 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18515       call sc_angular
18516       rij=1.0D0/rij  ! Reset this so it makes sense
18517
18518       sig0ij=sigma(itypi,itypj)
18519       sig=sig0ij*dsqrt(1.0D0/sigsq)
18520
18521       ljXs=sig-sig0ij
18522       ljA=eps1*eps2rt**2*eps3rt**2
18523       ljB=ljA*bb_aq(itypi,itypj)
18524       ljA=ljA*aa_aq(itypi,itypj)
18525       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18526
18527       ssXs=d0cm
18528       deltat1=1.0d0-om1
18529       deltat2=1.0d0+om2
18530       deltat12=om2-om1+2.0d0
18531       cosphi=om12-om1*om2
18532       ssA=akcm
18533       ssB=akct*deltat12
18534       ssC=ss_depth &
18535          +akth*(deltat1*deltat1+deltat2*deltat2) &
18536          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18537       ssxm=ssXs-0.5D0*ssB/ssA
18538
18539 !-------TESTING CODE
18540 !$$$c     Some extra output
18541 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18542 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18543 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18544 !$$$      if (ssx0.gt.0.0d0) then
18545 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18546 !$$$      else
18547 !$$$        ssx0=ssxm
18548 !$$$      endif
18549 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18550 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18551 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18552 !$$$      return
18553 !-------END TESTING CODE
18554
18555 !-------TESTING CODE
18556 !     Stop and plot energy and derivative as a function of distance
18557       if (checkstop) then
18558       ssm=ssC-0.25D0*ssB*ssB/ssA
18559       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18560       if (ssm.lt.ljm .and. &
18561            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18562         nicheck=1000
18563         njcheck=1
18564         deps=0.5d-7
18565       else
18566         checkstop=.false.
18567       endif
18568       endif
18569       if (.not.checkstop) then
18570       nicheck=0
18571       njcheck=-1
18572       endif
18573
18574       do icheck=0,nicheck
18575       do jcheck=-1,njcheck
18576       if (checkstop) rij=(ssxm-1.0d0)+ &
18577            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18578 !-------END TESTING CODE
18579
18580       if (rij.gt.ljxm) then
18581       havebond=.false.
18582       ljd=rij-ljXs
18583       fac=(1.0D0/ljd)**expon
18584       e1=fac*fac*aa_aq(itypi,itypj)
18585       e2=fac*bb_aq(itypi,itypj)
18586       eij=eps1*eps2rt*eps3rt*(e1+e2)
18587       eps2der=eij*eps3rt
18588       eps3der=eij*eps2rt
18589       eij=eij*eps2rt*eps3rt
18590
18591       sigder=-sig/sigsq
18592       e1=e1*eps1*eps2rt**2*eps3rt**2
18593       ed=-expon*(e1+eij)/ljd
18594       sigder=ed*sigder
18595       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18596       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18597       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18598            -2.0D0*alf12*eps3der+sigder*sigsq_om12
18599       else if (rij.lt.ssxm) then
18600       havebond=.true.
18601       ssd=rij-ssXs
18602       eij=ssA*ssd*ssd+ssB*ssd+ssC
18603
18604       ed=2*akcm*ssd+akct*deltat12
18605       pom1=akct*ssd
18606       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18607       eom1=-2*akth*deltat1-pom1-om2*pom2
18608       eom2= 2*akth*deltat2+pom1-om1*pom2
18609       eom12=pom2
18610       else
18611       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18612
18613       d_ssxm(1)=0.5D0*akct/ssA
18614       d_ssxm(2)=-d_ssxm(1)
18615       d_ssxm(3)=0.0D0
18616
18617       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18618       d_ljxm(2)=d_ljxm(1)*sigsq_om2
18619       d_ljxm(3)=d_ljxm(1)*sigsq_om12
18620       d_ljxm(1)=d_ljxm(1)*sigsq_om1
18621
18622 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18623       xm=0.5d0*(ssxm+ljxm)
18624       do k=1,3
18625         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18626       enddo
18627       if (rij.lt.xm) then
18628         havebond=.true.
18629         ssm=ssC-0.25D0*ssB*ssB/ssA
18630         d_ssm(1)=0.5D0*akct*ssB/ssA
18631         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18632         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18633         d_ssm(3)=omega
18634         f1=(rij-xm)/(ssxm-xm)
18635         f2=(rij-ssxm)/(xm-ssxm)
18636         h1=h_base(f1,hd1)
18637         h2=h_base(f2,hd2)
18638         eij=ssm*h1+Ht*h2
18639         delta_inv=1.0d0/(xm-ssxm)
18640         deltasq_inv=delta_inv*delta_inv
18641         fac=ssm*hd1-Ht*hd2
18642         fac1=deltasq_inv*fac*(xm-rij)
18643         fac2=deltasq_inv*fac*(rij-ssxm)
18644         ed=delta_inv*(Ht*hd2-ssm*hd1)
18645         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18646         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18647         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18648       else
18649         havebond=.false.
18650         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18651         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18652         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18653         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18654              alf12/eps3rt)
18655         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18656         f1=(rij-ljxm)/(xm-ljxm)
18657         f2=(rij-xm)/(ljxm-xm)
18658         h1=h_base(f1,hd1)
18659         h2=h_base(f2,hd2)
18660         eij=Ht*h1+ljm*h2
18661         delta_inv=1.0d0/(ljxm-xm)
18662         deltasq_inv=delta_inv*delta_inv
18663         fac=Ht*hd1-ljm*hd2
18664         fac1=deltasq_inv*fac*(ljxm-rij)
18665         fac2=deltasq_inv*fac*(rij-xm)
18666         ed=delta_inv*(ljm*hd2-Ht*hd1)
18667         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18668         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18669         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18670       endif
18671 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18672
18673 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18674 !$$$        ssd=rij-ssXs
18675 !$$$        ljd=rij-ljXs
18676 !$$$        fac1=rij-ljxm
18677 !$$$        fac2=rij-ssxm
18678 !$$$
18679 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18680 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18681 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18682 !$$$
18683 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18684 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18685 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18686 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18687 !$$$        d_ssm(3)=omega
18688 !$$$
18689 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18690 !$$$        do k=1,3
18691 !$$$          d_ljm(k)=ljm*d_ljB(k)
18692 !$$$        enddo
18693 !$$$        ljm=ljm*ljB
18694 !$$$
18695 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18696 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18697 !$$$        d_ss(2)=akct*ssd
18698 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18699 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18700 !$$$        d_ss(3)=omega
18701 !$$$
18702 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18703 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18704 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18705 !$$$        do k=1,3
18706 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18707 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18708 !$$$        enddo
18709 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18710 !$$$
18711 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18712 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18713 !$$$        h1=h_base(f1,hd1)
18714 !$$$        h2=h_base(f2,hd2)
18715 !$$$        eij=ss*h1+ljf*h2
18716 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18717 !$$$        deltasq_inv=delta_inv*delta_inv
18718 !$$$        fac=ljf*hd2-ss*hd1
18719 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18720 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18721 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18722 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18723 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18724 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18725 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18726 !$$$
18727 !$$$        havebond=.false.
18728 !$$$        if (ed.gt.0.0d0) havebond=.true.
18729 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18730
18731       endif
18732
18733       if (havebond) then
18734 !#ifndef CLUST
18735 !#ifndef WHAM
18736 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18737 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18738 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18739 !        endif
18740 !#endif
18741 !#endif
18742       dyn_ssbond_ij(i,j)=eij
18743       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18744       dyn_ssbond_ij(i,j)=1.0d300
18745 !#ifndef CLUST
18746 !#ifndef WHAM
18747 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18748 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18749 !#endif
18750 !#endif
18751       endif
18752
18753 !-------TESTING CODE
18754 !el      if (checkstop) then
18755       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18756            "CHECKSTOP",rij,eij,ed
18757       echeck(jcheck)=eij
18758 !el      endif
18759       enddo
18760       if (checkstop) then
18761       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18762       endif
18763       enddo
18764       if (checkstop) then
18765       transgrad=.true.
18766       checkstop=.false.
18767       endif
18768 !-------END TESTING CODE
18769
18770       do k=1,3
18771       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18772       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18773       enddo
18774       do k=1,3
18775       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18776       enddo
18777       do k=1,3
18778       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18779            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18780            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18781       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18782            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18783            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18784       enddo
18785 !grad      do k=i,j-1
18786 !grad        do l=1,3
18787 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18788 !grad        enddo
18789 !grad      enddo
18790
18791       do l=1,3
18792       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18793       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18794       enddo
18795
18796       return
18797       end subroutine dyn_ssbond_ene
18798 !--------------------------------------------------------------------------
18799        subroutine triple_ssbond_ene(resi,resj,resk,eij)
18800 !      implicit none
18801 !      Includes
18802       use calc_data
18803       use comm_sschecks
18804 !      include 'DIMENSIONS'
18805 !      include 'COMMON.SBRIDGE'
18806 !      include 'COMMON.CHAIN'
18807 !      include 'COMMON.DERIV'
18808 !      include 'COMMON.LOCAL'
18809 !      include 'COMMON.INTERACT'
18810 !      include 'COMMON.VAR'
18811 !      include 'COMMON.IOUNITS'
18812 !      include 'COMMON.CALC'
18813 #ifndef CLUST
18814 #ifndef WHAM
18815        use MD_data
18816 !      include 'COMMON.MD'
18817 !      use MD, only: totT,t_bath
18818 #endif
18819 #endif
18820       double precision h_base
18821       external h_base
18822
18823 !c     Input arguments
18824       integer resi,resj,resk,m,itypi,itypj,itypk
18825
18826 !c     Output arguments
18827       double precision eij,eij1,eij2,eij3
18828
18829 !c     Local variables
18830       logical havebond
18831 !c      integer itypi,itypj,k,l
18832       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18833       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18834       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18835       double precision sig0ij,ljd,sig,fac,e1,e2
18836       double precision dcosom1(3),dcosom2(3),ed
18837       double precision pom1,pom2
18838       double precision ljA,ljB,ljXs
18839       double precision d_ljB(1:3)
18840       double precision ssA,ssB,ssC,ssXs
18841       double precision ssxm,ljxm,ssm,ljm
18842       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18843       eij=0.0
18844       if (dtriss.eq.0) return
18845       i=resi
18846       j=resj
18847       k=resk
18848 !C      write(iout,*) resi,resj,resk
18849       itypi=itype(i,1)
18850       dxi=dc_norm(1,nres+i)
18851       dyi=dc_norm(2,nres+i)
18852       dzi=dc_norm(3,nres+i)
18853       dsci_inv=vbld_inv(i+nres)
18854       xi=c(1,nres+i)
18855       yi=c(2,nres+i)
18856       zi=c(3,nres+i)
18857       call to_box(xi,yi,zi)
18858       itypj=itype(j,1)
18859       xj=c(1,nres+j)
18860       yj=c(2,nres+j)
18861       zj=c(3,nres+j)
18862       call to_box(xj,yj,zj)
18863       dxj=dc_norm(1,nres+j)
18864       dyj=dc_norm(2,nres+j)
18865       dzj=dc_norm(3,nres+j)
18866       dscj_inv=vbld_inv(j+nres)
18867       itypk=itype(k,1)
18868       xk=c(1,nres+k)
18869       yk=c(2,nres+k)
18870       zk=c(3,nres+k)
18871        call to_box(xk,yk,zk)
18872       dxk=dc_norm(1,nres+k)
18873       dyk=dc_norm(2,nres+k)
18874       dzk=dc_norm(3,nres+k)
18875       dscj_inv=vbld_inv(k+nres)
18876       xij=xj-xi
18877       xik=xk-xi
18878       xjk=xk-xj
18879       yij=yj-yi
18880       yik=yk-yi
18881       yjk=yk-yj
18882       zij=zj-zi
18883       zik=zk-zi
18884       zjk=zk-zj
18885       rrij=(xij*xij+yij*yij+zij*zij)
18886       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18887       rrik=(xik*xik+yik*yik+zik*zik)
18888       rik=dsqrt(rrik)
18889       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18890       rjk=dsqrt(rrjk)
18891 !C there are three combination of distances for each trisulfide bonds
18892 !C The first case the ith atom is the center
18893 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18894 !C distance y is second distance the a,b,c,d are parameters derived for
18895 !C this problem d parameter was set as a penalty currenlty set to 1.
18896       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18897       eij1=0.0d0
18898       else
18899       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18900       endif
18901 !C second case jth atom is center
18902       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18903       eij2=0.0d0
18904       else
18905       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18906       endif
18907 !C the third case kth atom is the center
18908       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18909       eij3=0.0d0
18910       else
18911       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18912       endif
18913 !C      eij2=0.0
18914 !C      eij3=0.0
18915 !C      eij1=0.0
18916       eij=eij1+eij2+eij3
18917 !C      write(iout,*)i,j,k,eij
18918 !C The energy penalty calculated now time for the gradient part
18919 !C derivative over rij
18920       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18921       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18922           gg(1)=xij*fac/rij
18923           gg(2)=yij*fac/rij
18924           gg(3)=zij*fac/rij
18925       do m=1,3
18926       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18927       gvdwx(m,j)=gvdwx(m,j)+gg(m)
18928       enddo
18929
18930       do l=1,3
18931       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18932       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18933       enddo
18934 !C now derivative over rik
18935       fac=-eij1**2/dtriss* &
18936       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18937       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18938           gg(1)=xik*fac/rik
18939           gg(2)=yik*fac/rik
18940           gg(3)=zik*fac/rik
18941       do m=1,3
18942       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18943       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18944       enddo
18945       do l=1,3
18946       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18947       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18948       enddo
18949 !C now derivative over rjk
18950       fac=-eij2**2/dtriss* &
18951       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18952       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18953           gg(1)=xjk*fac/rjk
18954           gg(2)=yjk*fac/rjk
18955           gg(3)=zjk*fac/rjk
18956       do m=1,3
18957       gvdwx(m,j)=gvdwx(m,j)-gg(m)
18958       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18959       enddo
18960       do l=1,3
18961       gvdwc(l,j)=gvdwc(l,j)-gg(l)
18962       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18963       enddo
18964       return
18965       end subroutine triple_ssbond_ene
18966
18967
18968
18969 !-----------------------------------------------------------------------------
18970       real(kind=8) function h_base(x,deriv)
18971 !     A smooth function going 0->1 in range [0,1]
18972 !     It should NOT be called outside range [0,1], it will not work there.
18973       implicit none
18974
18975 !     Input arguments
18976       real(kind=8) :: x
18977
18978 !     Output arguments
18979       real(kind=8) :: deriv
18980
18981 !     Local variables
18982       real(kind=8) :: xsq
18983
18984
18985 !     Two parabolas put together.  First derivative zero at extrema
18986 !$$$      if (x.lt.0.5D0) then
18987 !$$$        h_base=2.0D0*x*x
18988 !$$$        deriv=4.0D0*x
18989 !$$$      else
18990 !$$$        deriv=1.0D0-x
18991 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18992 !$$$        deriv=4.0D0*deriv
18993 !$$$      endif
18994
18995 !     Third degree polynomial.  First derivative zero at extrema
18996       h_base=x*x*(3.0d0-2.0d0*x)
18997       deriv=6.0d0*x*(1.0d0-x)
18998
18999 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19000 !$$$      xsq=x*x
19001 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19002 !$$$      deriv=x-1.0d0
19003 !$$$      deriv=deriv*deriv
19004 !$$$      deriv=30.0d0*xsq*deriv
19005
19006       return
19007       end function h_base
19008 !-----------------------------------------------------------------------------
19009       subroutine dyn_set_nss
19010 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19011 !      implicit none
19012       use MD_data, only: totT,t_bath
19013 !     Includes
19014 !      include 'DIMENSIONS'
19015 #ifdef MPI
19016       include "mpif.h"
19017 #endif
19018 !      include 'COMMON.SBRIDGE'
19019 !      include 'COMMON.CHAIN'
19020 !      include 'COMMON.IOUNITS'
19021 !      include 'COMMON.SETUP'
19022 !      include 'COMMON.MD'
19023 !     Local variables
19024       real(kind=8) :: emin
19025       integer :: i,j,imin,ierr
19026       integer :: diff,allnss,newnss
19027       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19028             newihpb,newjhpb
19029       logical :: found
19030       integer,dimension(0:nfgtasks) :: i_newnss
19031       integer,dimension(0:nfgtasks) :: displ
19032       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19033       integer :: g_newnss
19034
19035       allnss=0
19036       do i=1,nres-1
19037       do j=i+1,nres
19038         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19039           allnss=allnss+1
19040           allflag(allnss)=0
19041           allihpb(allnss)=i
19042           alljhpb(allnss)=j
19043         endif
19044       enddo
19045       enddo
19046
19047 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19048
19049  1    emin=1.0d300
19050       do i=1,allnss
19051       if (allflag(i).eq.0 .and. &
19052            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19053         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19054         imin=i
19055       endif
19056       enddo
19057       if (emin.lt.1.0d300) then
19058       allflag(imin)=1
19059       do i=1,allnss
19060         if (allflag(i).eq.0 .and. &
19061              (allihpb(i).eq.allihpb(imin) .or. &
19062              alljhpb(i).eq.allihpb(imin) .or. &
19063              allihpb(i).eq.alljhpb(imin) .or. &
19064              alljhpb(i).eq.alljhpb(imin))) then
19065           allflag(i)=-1
19066         endif
19067       enddo
19068       goto 1
19069       endif
19070
19071 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19072
19073       newnss=0
19074       do i=1,allnss
19075       if (allflag(i).eq.1) then
19076         newnss=newnss+1
19077         newihpb(newnss)=allihpb(i)
19078         newjhpb(newnss)=alljhpb(i)
19079       endif
19080       enddo
19081
19082 #ifdef MPI
19083       if (nfgtasks.gt.1)then
19084
19085       call MPI_Reduce(newnss,g_newnss,1,&
19086         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19087       call MPI_Gather(newnss,1,MPI_INTEGER,&
19088                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19089       displ(0)=0
19090       do i=1,nfgtasks-1,1
19091         displ(i)=i_newnss(i-1)+displ(i-1)
19092       enddo
19093       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19094                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19095                    king,FG_COMM,IERR)
19096       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19097                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19098                    king,FG_COMM,IERR)
19099       if(fg_rank.eq.0) then
19100 !         print *,'g_newnss',g_newnss
19101 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19102 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19103        newnss=g_newnss
19104        do i=1,newnss
19105         newihpb(i)=g_newihpb(i)
19106         newjhpb(i)=g_newjhpb(i)
19107        enddo
19108       endif
19109       endif
19110 #endif
19111
19112       diff=newnss-nss
19113
19114 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19115 !       print *,newnss,nss,maxdim
19116       do i=1,nss
19117       found=.false.
19118 !        print *,newnss
19119       do j=1,newnss
19120 !!          print *,j
19121         if (idssb(i).eq.newihpb(j) .and. &
19122              jdssb(i).eq.newjhpb(j)) found=.true.
19123       enddo
19124 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19125 !        write(iout,*) "found",found,i,j
19126       if (.not.found.and.fg_rank.eq.0) &
19127           write(iout,'(a15,f12.2,f8.1,2i5)') &
19128            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19129 #endif
19130       enddo
19131
19132       do i=1,newnss
19133       found=.false.
19134       do j=1,nss
19135 !          print *,i,j
19136         if (newihpb(i).eq.idssb(j) .and. &
19137              newjhpb(i).eq.jdssb(j)) found=.true.
19138       enddo
19139 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19140 !        write(iout,*) "found",found,i,j
19141       if (.not.found.and.fg_rank.eq.0) &
19142           write(iout,'(a15,f12.2,f8.1,2i5)') &
19143            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19144 #endif
19145       enddo
19146 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19147       nss=newnss
19148       do i=1,nss
19149       idssb(i)=newihpb(i)
19150       jdssb(i)=newjhpb(i)
19151       enddo
19152 !#else
19153 !      nss=0
19154 !#endif
19155
19156       return
19157       end subroutine dyn_set_nss
19158 ! Lipid transfer energy function
19159       subroutine Eliptransfer(eliptran)
19160 !C this is done by Adasko
19161 !C      print *,"wchodze"
19162 !C structure of box:
19163 !C      water
19164 !C--bordliptop-- buffore starts
19165 !C--bufliptop--- here true lipid starts
19166 !C      lipid
19167 !C--buflipbot--- lipid ends buffore starts
19168 !C--bordlipbot--buffore ends
19169       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19170       integer :: i
19171       eliptran=0.0
19172 !      print *, "I am in eliptran"
19173       do i=ilip_start,ilip_end
19174 !C       do i=1,1
19175       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19176        cycle
19177
19178       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19179       if (positi.le.0.0) positi=positi+boxzsize
19180 !C        print *,i
19181 !C first for peptide groups
19182 !c for each residue check if it is in lipid or lipid water border area
19183        if ((positi.gt.bordlipbot)  &
19184       .and.(positi.lt.bordliptop)) then
19185 !C the energy transfer exist
19186       if (positi.lt.buflipbot) then
19187 !C what fraction I am in
19188        fracinbuf=1.0d0-      &
19189            ((positi-bordlipbot)/lipbufthick)
19190 !C lipbufthick is thickenes of lipid buffore
19191        sslip=sscalelip(fracinbuf)
19192        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19193        eliptran=eliptran+sslip*pepliptran
19194        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19195        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19196 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19197
19198 !C        print *,"doing sccale for lower part"
19199 !C         print *,i,sslip,fracinbuf,ssgradlip
19200       elseif (positi.gt.bufliptop) then
19201        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19202        sslip=sscalelip(fracinbuf)
19203        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19204        eliptran=eliptran+sslip*pepliptran
19205        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19206        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19207 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19208 !C          print *, "doing sscalefor top part"
19209 !C         print *,i,sslip,fracinbuf,ssgradlip
19210       else
19211        eliptran=eliptran+pepliptran
19212 !C         print *,"I am in true lipid"
19213       endif
19214 !C       else
19215 !C       eliptran=elpitran+0.0 ! I am in water
19216        endif
19217        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19218        enddo
19219 ! here starts the side chain transfer
19220        do i=ilip_start,ilip_end
19221       if (itype(i,1).eq.ntyp1) cycle
19222       positi=(mod(c(3,i+nres),boxzsize))
19223       if (positi.le.0) positi=positi+boxzsize
19224 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19225 !c for each residue check if it is in lipid or lipid water border area
19226 !C       respos=mod(c(3,i+nres),boxzsize)
19227 !C       print *,positi,bordlipbot,buflipbot
19228        if ((positi.gt.bordlipbot) &
19229        .and.(positi.lt.bordliptop)) then
19230 !C the energy transfer exist
19231       if (positi.lt.buflipbot) then
19232        fracinbuf=1.0d0-   &
19233          ((positi-bordlipbot)/lipbufthick)
19234 !C lipbufthick is thickenes of lipid buffore
19235        sslip=sscalelip(fracinbuf)
19236        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19237        eliptran=eliptran+sslip*liptranene(itype(i,1))
19238        gliptranx(3,i)=gliptranx(3,i) &
19239       +ssgradlip*liptranene(itype(i,1))
19240        gliptranc(3,i-1)= gliptranc(3,i-1) &
19241       +ssgradlip*liptranene(itype(i,1))
19242 !C         print *,"doing sccale for lower part"
19243       elseif (positi.gt.bufliptop) then
19244        fracinbuf=1.0d0-  &
19245       ((bordliptop-positi)/lipbufthick)
19246        sslip=sscalelip(fracinbuf)
19247        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19248        eliptran=eliptran+sslip*liptranene(itype(i,1))
19249        gliptranx(3,i)=gliptranx(3,i)  &
19250        +ssgradlip*liptranene(itype(i,1))
19251        gliptranc(3,i-1)= gliptranc(3,i-1) &
19252       +ssgradlip*liptranene(itype(i,1))
19253 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19254       else
19255        eliptran=eliptran+liptranene(itype(i,1))
19256 !C         print *,"I am in true lipid"
19257       endif
19258       endif ! if in lipid or buffor
19259 !C       else
19260 !C       eliptran=elpitran+0.0 ! I am in water
19261       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19262        enddo
19263        return
19264        end  subroutine Eliptransfer
19265 !----------------------------------NANO FUNCTIONS
19266 !C-----------------------------------------------------------------------
19267 !C-----------------------------------------------------------
19268 !C This subroutine is to mimic the histone like structure but as well can be
19269 !C utilizet to nanostructures (infinit) small modification has to be used to
19270 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19271 !C gradient has to be modified at the ends
19272 !C The energy function is Kihara potential
19273 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19274 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19275 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19276 !C simple Kihara potential
19277       subroutine calctube(Etube)
19278       real(kind=8),dimension(3) :: vectube
19279       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19280        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19281        sc_aa_tube,sc_bb_tube
19282       integer :: i,j,iti
19283       Etube=0.0d0
19284       do i=itube_start,itube_end
19285       enetube(i)=0.0d0
19286       enetube(i+nres)=0.0d0
19287       enddo
19288 !C first we calculate the distance from tube center
19289 !C for UNRES
19290        do i=itube_start,itube_end
19291 !C lets ommit dummy atoms for now
19292        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19293 !C now calculate distance from center of tube and direction vectors
19294       xmin=boxxsize
19295       ymin=boxysize
19296 ! Find minimum distance in periodic box
19297       do j=-1,1
19298        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19299        vectube(1)=vectube(1)+boxxsize*j
19300        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19301        vectube(2)=vectube(2)+boxysize*j
19302        xminact=abs(vectube(1)-tubecenter(1))
19303        yminact=abs(vectube(2)-tubecenter(2))
19304          if (xmin.gt.xminact) then
19305           xmin=xminact
19306           xtemp=vectube(1)
19307          endif
19308          if (ymin.gt.yminact) then
19309            ymin=yminact
19310            ytemp=vectube(2)
19311           endif
19312        enddo
19313       vectube(1)=xtemp
19314       vectube(2)=ytemp
19315       vectube(1)=vectube(1)-tubecenter(1)
19316       vectube(2)=vectube(2)-tubecenter(2)
19317
19318 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19319 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19320
19321 !C as the tube is infinity we do not calculate the Z-vector use of Z
19322 !C as chosen axis
19323       vectube(3)=0.0d0
19324 !C now calculte the distance
19325        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19326 !C now normalize vector
19327       vectube(1)=vectube(1)/tub_r
19328       vectube(2)=vectube(2)/tub_r
19329 !C calculte rdiffrence between r and r0
19330       rdiff=tub_r-tubeR0
19331 !C and its 6 power
19332       rdiff6=rdiff**6.0d0
19333 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19334        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19335 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19336 !C       print *,rdiff,rdiff6,pep_aa_tube
19337 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19338 !C now we calculate gradient
19339        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19340           6.0d0*pep_bb_tube)/rdiff6/rdiff
19341 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19342 !C     &rdiff,fac
19343 !C now direction of gg_tube vector
19344       do j=1,3
19345       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19346       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19347       enddo
19348       enddo
19349 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19350 !C        print *,gg_tube(1,0),"TU"
19351
19352
19353        do i=itube_start,itube_end
19354 !C Lets not jump over memory as we use many times iti
19355        iti=itype(i,1)
19356 !C lets ommit dummy atoms for now
19357        if ((iti.eq.ntyp1)  &
19358 !C in UNRES uncomment the line below as GLY has no side-chain...
19359 !C      .or.(iti.eq.10)
19360       ) cycle
19361       xmin=boxxsize
19362       ymin=boxysize
19363       do j=-1,1
19364        vectube(1)=mod((c(1,i+nres)),boxxsize)
19365        vectube(1)=vectube(1)+boxxsize*j
19366        vectube(2)=mod((c(2,i+nres)),boxysize)
19367        vectube(2)=vectube(2)+boxysize*j
19368
19369        xminact=abs(vectube(1)-tubecenter(1))
19370        yminact=abs(vectube(2)-tubecenter(2))
19371          if (xmin.gt.xminact) then
19372           xmin=xminact
19373           xtemp=vectube(1)
19374          endif
19375          if (ymin.gt.yminact) then
19376            ymin=yminact
19377            ytemp=vectube(2)
19378           endif
19379        enddo
19380       vectube(1)=xtemp
19381       vectube(2)=ytemp
19382 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19383 !C     &     tubecenter(2)
19384       vectube(1)=vectube(1)-tubecenter(1)
19385       vectube(2)=vectube(2)-tubecenter(2)
19386
19387 !C as the tube is infinity we do not calculate the Z-vector use of Z
19388 !C as chosen axis
19389       vectube(3)=0.0d0
19390 !C now calculte the distance
19391        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19392 !C now normalize vector
19393       vectube(1)=vectube(1)/tub_r
19394       vectube(2)=vectube(2)/tub_r
19395
19396 !C calculte rdiffrence between r and r0
19397       rdiff=tub_r-tubeR0
19398 !C and its 6 power
19399       rdiff6=rdiff**6.0d0
19400 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19401        sc_aa_tube=sc_aa_tube_par(iti)
19402        sc_bb_tube=sc_bb_tube_par(iti)
19403        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19404        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19405            6.0d0*sc_bb_tube/rdiff6/rdiff
19406 !C now direction of gg_tube vector
19407        do j=1,3
19408         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19409         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19410        enddo
19411       enddo
19412       do i=itube_start,itube_end
19413         Etube=Etube+enetube(i)+enetube(i+nres)
19414       enddo
19415 !C        print *,"ETUBE", etube
19416       return
19417       end subroutine calctube
19418 !C TO DO 1) add to total energy
19419 !C       2) add to gradient summation
19420 !C       3) add reading parameters (AND of course oppening of PARAM file)
19421 !C       4) add reading the center of tube
19422 !C       5) add COMMONs
19423 !C       6) add to zerograd
19424 !C       7) allocate matrices
19425
19426
19427 !C-----------------------------------------------------------------------
19428 !C-----------------------------------------------------------
19429 !C This subroutine is to mimic the histone like structure but as well can be
19430 !C utilizet to nanostructures (infinit) small modification has to be used to
19431 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19432 !C gradient has to be modified at the ends
19433 !C The energy function is Kihara potential
19434 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19435 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19436 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19437 !C simple Kihara potential
19438       subroutine calctube2(Etube)
19439           real(kind=8),dimension(3) :: vectube
19440       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19441        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19442        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19443       integer:: i,j,iti
19444       Etube=0.0d0
19445       do i=itube_start,itube_end
19446       enetube(i)=0.0d0
19447       enetube(i+nres)=0.0d0
19448       enddo
19449 !C first we calculate the distance from tube center
19450 !C first sugare-phosphate group for NARES this would be peptide group
19451 !C for UNRES
19452        do i=itube_start,itube_end
19453 !C lets ommit dummy atoms for now
19454
19455        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19456 !C now calculate distance from center of tube and direction vectors
19457 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19458 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19459 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19460 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19461       xmin=boxxsize
19462       ymin=boxysize
19463       do j=-1,1
19464        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19465        vectube(1)=vectube(1)+boxxsize*j
19466        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19467        vectube(2)=vectube(2)+boxysize*j
19468
19469        xminact=abs(vectube(1)-tubecenter(1))
19470        yminact=abs(vectube(2)-tubecenter(2))
19471          if (xmin.gt.xminact) then
19472           xmin=xminact
19473           xtemp=vectube(1)
19474          endif
19475          if (ymin.gt.yminact) then
19476            ymin=yminact
19477            ytemp=vectube(2)
19478           endif
19479        enddo
19480       vectube(1)=xtemp
19481       vectube(2)=ytemp
19482       vectube(1)=vectube(1)-tubecenter(1)
19483       vectube(2)=vectube(2)-tubecenter(2)
19484
19485 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19486 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19487
19488 !C as the tube is infinity we do not calculate the Z-vector use of Z
19489 !C as chosen axis
19490       vectube(3)=0.0d0
19491 !C now calculte the distance
19492        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19493 !C now normalize vector
19494       vectube(1)=vectube(1)/tub_r
19495       vectube(2)=vectube(2)/tub_r
19496 !C calculte rdiffrence between r and r0
19497       rdiff=tub_r-tubeR0
19498 !C and its 6 power
19499       rdiff6=rdiff**6.0d0
19500 !C THIS FRAGMENT MAKES TUBE FINITE
19501       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19502       if (positi.le.0) positi=positi+boxzsize
19503 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19504 !c for each residue check if it is in lipid or lipid water border area
19505 !C       respos=mod(c(3,i+nres),boxzsize)
19506 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19507        if ((positi.gt.bordtubebot)  &
19508       .and.(positi.lt.bordtubetop)) then
19509 !C the energy transfer exist
19510       if (positi.lt.buftubebot) then
19511        fracinbuf=1.0d0-  &
19512          ((positi-bordtubebot)/tubebufthick)
19513 !C lipbufthick is thickenes of lipid buffore
19514        sstube=sscalelip(fracinbuf)
19515        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19516 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19517        enetube(i)=enetube(i)+sstube*tubetranenepep
19518 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19519 !C     &+ssgradtube*tubetranene(itype(i,1))
19520 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19521 !C     &+ssgradtube*tubetranene(itype(i,1))
19522 !C         print *,"doing sccale for lower part"
19523       elseif (positi.gt.buftubetop) then
19524        fracinbuf=1.0d0-  &
19525       ((bordtubetop-positi)/tubebufthick)
19526        sstube=sscalelip(fracinbuf)
19527        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19528        enetube(i)=enetube(i)+sstube*tubetranenepep
19529 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19530 !C     &+ssgradtube*tubetranene(itype(i,1))
19531 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19532 !C     &+ssgradtube*tubetranene(itype(i,1))
19533 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19534       else
19535        sstube=1.0d0
19536        ssgradtube=0.0d0
19537        enetube(i)=enetube(i)+sstube*tubetranenepep
19538 !C         print *,"I am in true lipid"
19539       endif
19540       else
19541 !C          sstube=0.0d0
19542 !C          ssgradtube=0.0d0
19543       cycle
19544       endif ! if in lipid or buffor
19545
19546 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19547        enetube(i)=enetube(i)+sstube* &
19548       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19549 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19550 !C       print *,rdiff,rdiff6,pep_aa_tube
19551 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19552 !C now we calculate gradient
19553        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19554            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19555 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19556 !C     &rdiff,fac
19557
19558 !C now direction of gg_tube vector
19559        do j=1,3
19560       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19561       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19562       enddo
19563        gg_tube(3,i)=gg_tube(3,i)  &
19564        +ssgradtube*enetube(i)/sstube/2.0d0
19565        gg_tube(3,i-1)= gg_tube(3,i-1)  &
19566        +ssgradtube*enetube(i)/sstube/2.0d0
19567
19568       enddo
19569 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19570 !C        print *,gg_tube(1,0),"TU"
19571       do i=itube_start,itube_end
19572 !C Lets not jump over memory as we use many times iti
19573        iti=itype(i,1)
19574 !C lets ommit dummy atoms for now
19575        if ((iti.eq.ntyp1) &
19576 !!C in UNRES uncomment the line below as GLY has no side-chain...
19577          .or.(iti.eq.10) &
19578         ) cycle
19579         vectube(1)=c(1,i+nres)
19580         vectube(1)=mod(vectube(1),boxxsize)
19581         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19582         vectube(2)=c(2,i+nres)
19583         vectube(2)=mod(vectube(2),boxysize)
19584         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19585
19586       vectube(1)=vectube(1)-tubecenter(1)
19587       vectube(2)=vectube(2)-tubecenter(2)
19588 !C THIS FRAGMENT MAKES TUBE FINITE
19589       positi=(mod(c(3,i+nres),boxzsize))
19590       if (positi.le.0) positi=positi+boxzsize
19591 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19592 !c for each residue check if it is in lipid or lipid water border area
19593 !C       respos=mod(c(3,i+nres),boxzsize)
19594 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19595
19596        if ((positi.gt.bordtubebot)  &
19597       .and.(positi.lt.bordtubetop)) then
19598 !C the energy transfer exist
19599       if (positi.lt.buftubebot) then
19600        fracinbuf=1.0d0- &
19601           ((positi-bordtubebot)/tubebufthick)
19602 !C lipbufthick is thickenes of lipid buffore
19603        sstube=sscalelip(fracinbuf)
19604        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19605 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19606        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19607 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19608 !C     &+ssgradtube*tubetranene(itype(i,1))
19609 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19610 !C     &+ssgradtube*tubetranene(itype(i,1))
19611 !C         print *,"doing sccale for lower part"
19612       elseif (positi.gt.buftubetop) then
19613        fracinbuf=1.0d0- &
19614       ((bordtubetop-positi)/tubebufthick)
19615
19616        sstube=sscalelip(fracinbuf)
19617        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19618        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19619 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19620 !C     &+ssgradtube*tubetranene(itype(i,1))
19621 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19622 !C     &+ssgradtube*tubetranene(itype(i,1))
19623 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19624       else
19625        sstube=1.0d0
19626        ssgradtube=0.0d0
19627        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19628 !C         print *,"I am in true lipid"
19629       endif
19630       else
19631 !C          sstube=0.0d0
19632 !C          ssgradtube=0.0d0
19633       cycle
19634       endif ! if in lipid or buffor
19635 !CEND OF FINITE FRAGMENT
19636 !C as the tube is infinity we do not calculate the Z-vector use of Z
19637 !C as chosen axis
19638       vectube(3)=0.0d0
19639 !C now calculte the distance
19640        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19641 !C now normalize vector
19642       vectube(1)=vectube(1)/tub_r
19643       vectube(2)=vectube(2)/tub_r
19644 !C calculte rdiffrence between r and r0
19645       rdiff=tub_r-tubeR0
19646 !C and its 6 power
19647       rdiff6=rdiff**6.0d0
19648 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19649        sc_aa_tube=sc_aa_tube_par(iti)
19650        sc_bb_tube=sc_bb_tube_par(iti)
19651        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19652                    *sstube+enetube(i+nres)
19653 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19654 !C now we calculate gradient
19655        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19656           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19657 !C now direction of gg_tube vector
19658        do j=1,3
19659         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19660         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19661        enddo
19662        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19663        +ssgradtube*enetube(i+nres)/sstube
19664        gg_tube(3,i-1)= gg_tube(3,i-1) &
19665        +ssgradtube*enetube(i+nres)/sstube
19666
19667       enddo
19668       do i=itube_start,itube_end
19669         Etube=Etube+enetube(i)+enetube(i+nres)
19670       enddo
19671 !C        print *,"ETUBE", etube
19672       return
19673       end subroutine calctube2
19674 !=====================================================================================================================================
19675       subroutine calcnano(Etube)
19676       real(kind=8),dimension(3) :: vectube
19677
19678       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19679        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19680        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19681        integer:: i,j,iti,r
19682
19683       Etube=0.0d0
19684 !      print *,itube_start,itube_end,"poczatek"
19685       do i=itube_start,itube_end
19686       enetube(i)=0.0d0
19687       enetube(i+nres)=0.0d0
19688       enddo
19689 !C first we calculate the distance from tube center
19690 !C first sugare-phosphate group for NARES this would be peptide group
19691 !C for UNRES
19692        do i=itube_start,itube_end
19693 !C lets ommit dummy atoms for now
19694        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19695 !C now calculate distance from center of tube and direction vectors
19696       xmin=boxxsize
19697       ymin=boxysize
19698       zmin=boxzsize
19699
19700       do j=-1,1
19701        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19702        vectube(1)=vectube(1)+boxxsize*j
19703        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19704        vectube(2)=vectube(2)+boxysize*j
19705        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19706        vectube(3)=vectube(3)+boxzsize*j
19707
19708
19709        xminact=dabs(vectube(1)-tubecenter(1))
19710        yminact=dabs(vectube(2)-tubecenter(2))
19711        zminact=dabs(vectube(3)-tubecenter(3))
19712
19713          if (xmin.gt.xminact) then
19714           xmin=xminact
19715           xtemp=vectube(1)
19716          endif
19717          if (ymin.gt.yminact) then
19718            ymin=yminact
19719            ytemp=vectube(2)
19720           endif
19721          if (zmin.gt.zminact) then
19722            zmin=zminact
19723            ztemp=vectube(3)
19724           endif
19725        enddo
19726       vectube(1)=xtemp
19727       vectube(2)=ytemp
19728       vectube(3)=ztemp
19729
19730       vectube(1)=vectube(1)-tubecenter(1)
19731       vectube(2)=vectube(2)-tubecenter(2)
19732       vectube(3)=vectube(3)-tubecenter(3)
19733
19734 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19735 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19736 !C as the tube is infinity we do not calculate the Z-vector use of Z
19737 !C as chosen axis
19738 !C      vectube(3)=0.0d0
19739 !C now calculte the distance
19740        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19741 !C now normalize vector
19742       vectube(1)=vectube(1)/tub_r
19743       vectube(2)=vectube(2)/tub_r
19744       vectube(3)=vectube(3)/tub_r
19745 !C calculte rdiffrence between r and r0
19746       rdiff=tub_r-tubeR0
19747 !C and its 6 power
19748       rdiff6=rdiff**6.0d0
19749 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19750        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19751 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19752 !C       print *,rdiff,rdiff6,pep_aa_tube
19753 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19754 !C now we calculate gradient
19755        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19756           6.0d0*pep_bb_tube)/rdiff6/rdiff
19757 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19758 !C     &rdiff,fac
19759        if (acavtubpep.eq.0.0d0) then
19760 !C go to 667
19761        enecavtube(i)=0.0
19762        faccav=0.0
19763        else
19764        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19765        enecavtube(i)=  &
19766       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19767       /denominator
19768        enecavtube(i)=0.0
19769        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19770       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19771       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19772       /denominator**2.0d0
19773 !C         faccav=0.0
19774 !C         fac=fac+faccav
19775 !C 667     continue
19776        endif
19777         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19778       do j=1,3
19779       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19780       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19781       enddo
19782       enddo
19783
19784        do i=itube_start,itube_end
19785       enecavtube(i)=0.0d0
19786 !C Lets not jump over memory as we use many times iti
19787        iti=itype(i,1)
19788 !C lets ommit dummy atoms for now
19789        if ((iti.eq.ntyp1) &
19790 !C in UNRES uncomment the line below as GLY has no side-chain...
19791 !C      .or.(iti.eq.10)
19792        ) cycle
19793       xmin=boxxsize
19794       ymin=boxysize
19795       zmin=boxzsize
19796       do j=-1,1
19797        vectube(1)=dmod((c(1,i+nres)),boxxsize)
19798        vectube(1)=vectube(1)+boxxsize*j
19799        vectube(2)=dmod((c(2,i+nres)),boxysize)
19800        vectube(2)=vectube(2)+boxysize*j
19801        vectube(3)=dmod((c(3,i+nres)),boxzsize)
19802        vectube(3)=vectube(3)+boxzsize*j
19803
19804
19805        xminact=dabs(vectube(1)-tubecenter(1))
19806        yminact=dabs(vectube(2)-tubecenter(2))
19807        zminact=dabs(vectube(3)-tubecenter(3))
19808
19809          if (xmin.gt.xminact) then
19810           xmin=xminact
19811           xtemp=vectube(1)
19812          endif
19813          if (ymin.gt.yminact) then
19814            ymin=yminact
19815            ytemp=vectube(2)
19816           endif
19817          if (zmin.gt.zminact) then
19818            zmin=zminact
19819            ztemp=vectube(3)
19820           endif
19821        enddo
19822       vectube(1)=xtemp
19823       vectube(2)=ytemp
19824       vectube(3)=ztemp
19825
19826 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19827 !C     &     tubecenter(2)
19828       vectube(1)=vectube(1)-tubecenter(1)
19829       vectube(2)=vectube(2)-tubecenter(2)
19830       vectube(3)=vectube(3)-tubecenter(3)
19831 !C now calculte the distance
19832        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19833 !C now normalize vector
19834       vectube(1)=vectube(1)/tub_r
19835       vectube(2)=vectube(2)/tub_r
19836       vectube(3)=vectube(3)/tub_r
19837
19838 !C calculte rdiffrence between r and r0
19839       rdiff=tub_r-tubeR0
19840 !C and its 6 power
19841       rdiff6=rdiff**6.0d0
19842        sc_aa_tube=sc_aa_tube_par(iti)
19843        sc_bb_tube=sc_bb_tube_par(iti)
19844        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19845 !C       enetube(i+nres)=0.0d0
19846 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19847 !C now we calculate gradient
19848        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19849           6.0d0*sc_bb_tube/rdiff6/rdiff
19850 !C       fac=0.0
19851 !C now direction of gg_tube vector
19852 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19853        if (acavtub(iti).eq.0.0d0) then
19854 !C go to 667
19855        enecavtube(i+nres)=0.0d0
19856        faccav=0.0d0
19857        else
19858        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19859        enecavtube(i+nres)=   &
19860       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19861       /denominator
19862 !C         enecavtube(i)=0.0
19863        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19864       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19865       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19866       /denominator**2.0d0
19867 !C         faccav=0.0
19868        fac=fac+faccav
19869 !C 667     continue
19870        endif
19871 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19872 !C     &   enecavtube(i),faccav
19873 !C         print *,"licz=",
19874 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19875 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19876        do j=1,3
19877         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19878         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19879        enddo
19880         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19881       enddo
19882
19883
19884
19885       do i=itube_start,itube_end
19886         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19887        +enecavtube(i+nres)
19888       enddo
19889 !        do i=1,20
19890 !         print *,"begin", i,"a"
19891 !         do r=1,10000
19892 !          rdiff=r/100.0d0
19893 !          rdiff6=rdiff**6.0d0
19894 !          sc_aa_tube=sc_aa_tube_par(i)
19895 !          sc_bb_tube=sc_bb_tube_par(i)
19896 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19897 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19898 !          enecavtube(i)=   &
19899 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19900 !         /denominator
19901
19902 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19903 !         enddo
19904 !         print *,"end",i,"a"
19905 !        enddo
19906 !C        print *,"ETUBE", etube
19907       return
19908       end subroutine calcnano
19909
19910 !===============================================
19911 !--------------------------------------------------------------------------------
19912 !C first for shielding is setting of function of side-chains
19913
19914        subroutine set_shield_fac2
19915        real(kind=8) :: div77_81=0.974996043d0, &
19916       div4_81=0.2222222222d0
19917        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19918        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19919        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19920        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19921 !C the vector between center of side_chain and peptide group
19922        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19923        pept_group,costhet_grad,cosphi_grad_long, &
19924        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19925        sh_frac_dist_grad,pep_side
19926       integer i,j,k
19927 !C      write(2,*) "ivec",ivec_start,ivec_end
19928       do i=1,nres
19929       fac_shield(i)=0.0d0
19930       ishield_list(i)=0
19931       do j=1,3
19932       grad_shield(j,i)=0.0d0
19933       enddo
19934       enddo
19935       do i=ivec_start,ivec_end
19936 !C      do i=1,nres-1
19937 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19938 !      ishield_list(i)=0
19939       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19940 !Cif there two consequtive dummy atoms there is no peptide group between them
19941 !C the line below has to be changed for FGPROC>1
19942       VolumeTotal=0.0
19943       do k=1,nres
19944        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19945        dist_pep_side=0.0
19946        dist_side_calf=0.0
19947        do j=1,3
19948 !C first lets set vector conecting the ithe side-chain with kth side-chain
19949       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19950 !C      pep_side(j)=2.0d0
19951 !C and vector conecting the side-chain with its proper calfa
19952       side_calf(j)=c(j,k+nres)-c(j,k)
19953 !C      side_calf(j)=2.0d0
19954       pept_group(j)=c(j,i)-c(j,i+1)
19955 !C lets have their lenght
19956       dist_pep_side=pep_side(j)**2+dist_pep_side
19957       dist_side_calf=dist_side_calf+side_calf(j)**2
19958       dist_pept_group=dist_pept_group+pept_group(j)**2
19959       enddo
19960        dist_pep_side=sqrt(dist_pep_side)
19961        dist_pept_group=sqrt(dist_pept_group)
19962        dist_side_calf=sqrt(dist_side_calf)
19963       do j=1,3
19964       pep_side_norm(j)=pep_side(j)/dist_pep_side
19965       side_calf_norm(j)=dist_side_calf
19966       enddo
19967 !C now sscale fraction
19968        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19969 !       print *,buff_shield,"buff",sh_frac_dist
19970 !C now sscale
19971       if (sh_frac_dist.le.0.0) cycle
19972 !C        print *,ishield_list(i),i
19973 !C If we reach here it means that this side chain reaches the shielding sphere
19974 !C Lets add him to the list for gradient
19975       ishield_list(i)=ishield_list(i)+1
19976 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19977 !C this list is essential otherwise problem would be O3
19978       shield_list(ishield_list(i),i)=k
19979 !C Lets have the sscale value
19980       if (sh_frac_dist.gt.1.0) then
19981        scale_fac_dist=1.0d0
19982        do j=1,3
19983        sh_frac_dist_grad(j)=0.0d0
19984        enddo
19985       else
19986        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19987                   *(2.0d0*sh_frac_dist-3.0d0)
19988        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19989                    /dist_pep_side/buff_shield*0.5d0
19990        do j=1,3
19991        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19992 !C         sh_frac_dist_grad(j)=0.0d0
19993 !C         scale_fac_dist=1.0d0
19994 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19995 !C     &                    sh_frac_dist_grad(j)
19996        enddo
19997       endif
19998 !C this is what is now we have the distance scaling now volume...
19999       short=short_r_sidechain(itype(k,1))
20000       long=long_r_sidechain(itype(k,1))
20001       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20002       sinthet=short/dist_pep_side*costhet
20003 !      print *,"SORT",short,long,sinthet,costhet
20004 !C now costhet_grad
20005 !C       costhet=0.6d0
20006 !C       sinthet=0.8
20007        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20008 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20009 !C     &             -short/dist_pep_side**2/costhet)
20010 !C       costhet_fac=0.0d0
20011        do j=1,3
20012        costhet_grad(j)=costhet_fac*pep_side(j)
20013        enddo
20014 !C remember for the final gradient multiply costhet_grad(j)
20015 !C for side_chain by factor -2 !
20016 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20017 !C pep_side0pept_group is vector multiplication
20018       pep_side0pept_group=0.0d0
20019       do j=1,3
20020       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20021       enddo
20022       cosalfa=(pep_side0pept_group/ &
20023       (dist_pep_side*dist_side_calf))
20024       fac_alfa_sin=1.0d0-cosalfa**2
20025       fac_alfa_sin=dsqrt(fac_alfa_sin)
20026       rkprim=fac_alfa_sin*(long-short)+short
20027 !C      rkprim=short
20028
20029 !C now costhet_grad
20030        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20031 !C       cosphi=0.6
20032        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20033        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20034          dist_pep_side**2)
20035 !C       sinphi=0.8
20036        do j=1,3
20037        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20038       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20039       *(long-short)/fac_alfa_sin*cosalfa/ &
20040       ((dist_pep_side*dist_side_calf))* &
20041       ((side_calf(j))-cosalfa* &
20042       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20043 !C       cosphi_grad_long(j)=0.0d0
20044       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20045       *(long-short)/fac_alfa_sin*cosalfa &
20046       /((dist_pep_side*dist_side_calf))* &
20047       (pep_side(j)- &
20048       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20049 !C       cosphi_grad_loc(j)=0.0d0
20050        enddo
20051 !C      print *,sinphi,sinthet
20052       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20053                    /VSolvSphere_div
20054 !C     &                    *wshield
20055 !C now the gradient...
20056       do j=1,3
20057       grad_shield(j,i)=grad_shield(j,i) &
20058 !C gradient po skalowaniu
20059                  +(sh_frac_dist_grad(j)*VofOverlap &
20060 !C  gradient po costhet
20061           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20062       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20063           sinphi/sinthet*costhet*costhet_grad(j) &
20064          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20065       )*wshield
20066 !C grad_shield_side is Cbeta sidechain gradient
20067       grad_shield_side(j,ishield_list(i),i)=&
20068            (sh_frac_dist_grad(j)*-2.0d0&
20069            *VofOverlap&
20070           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20071        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20072           sinphi/sinthet*costhet*costhet_grad(j)&
20073          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20074           )*wshield
20075 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20076 !            sinphi/sinthet,&
20077 !           +sinthet/sinphi,"HERE"
20078        grad_shield_loc(j,ishield_list(i),i)=   &
20079           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20080       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20081           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20082            ))&
20083            *wshield
20084 !         print *,grad_shield_loc(j,ishield_list(i),i)
20085       enddo
20086       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20087       enddo
20088       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20089
20090 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20091       enddo
20092       return
20093       end subroutine set_shield_fac2
20094 !----------------------------------------------------------------------------
20095 ! SOUBROUTINE FOR AFM
20096        subroutine AFMvel(Eafmforce)
20097        use MD_data, only:totTafm
20098       real(kind=8),dimension(3) :: diffafm
20099       real(kind=8) :: afmdist,Eafmforce
20100        integer :: i
20101 !C Only for check grad COMMENT if not used for checkgrad
20102 !C      totT=3.0d0
20103 !C--------------------------------------------------------
20104 !C      print *,"wchodze"
20105       afmdist=0.0d0
20106       Eafmforce=0.0d0
20107       do i=1,3
20108       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20109       afmdist=afmdist+diffafm(i)**2
20110       enddo
20111       afmdist=dsqrt(afmdist)
20112 !      totTafm=3.0
20113       Eafmforce=0.5d0*forceAFMconst &
20114       *(distafminit+totTafm*velAFMconst-afmdist)**2
20115 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20116       do i=1,3
20117       gradafm(i,afmend-1)=-forceAFMconst* &
20118        (distafminit+totTafm*velAFMconst-afmdist) &
20119        *diffafm(i)/afmdist
20120       gradafm(i,afmbeg-1)=forceAFMconst* &
20121       (distafminit+totTafm*velAFMconst-afmdist) &
20122       *diffafm(i)/afmdist
20123       enddo
20124 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20125       return
20126       end subroutine AFMvel
20127 !---------------------------------------------------------
20128        subroutine AFMforce(Eafmforce)
20129
20130       real(kind=8),dimension(3) :: diffafm
20131 !      real(kind=8) ::afmdist
20132       real(kind=8) :: afmdist,Eafmforce
20133       integer :: i
20134       afmdist=0.0d0
20135       Eafmforce=0.0d0
20136       do i=1,3
20137       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20138       afmdist=afmdist+diffafm(i)**2
20139       enddo
20140       afmdist=dsqrt(afmdist)
20141 !      print *,afmdist,distafminit
20142       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20143       do i=1,3
20144       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20145       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20146       enddo
20147 !C      print *,'AFM',Eafmforce
20148       return
20149       end subroutine AFMforce
20150
20151 !-----------------------------------------------------------------------------
20152 #ifdef WHAM
20153       subroutine read_ssHist
20154 !      implicit none
20155 !      Includes
20156 !      include 'DIMENSIONS'
20157 !      include "DIMENSIONS.FREE"
20158 !      include 'COMMON.FREE'
20159 !     Local variables
20160       integer :: i,j
20161       character(len=80) :: controlcard
20162
20163       do i=1,dyn_nssHist
20164       call card_concat(controlcard,.true.)
20165       read(controlcard,*) &
20166            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20167       enddo
20168
20169       return
20170       end subroutine read_ssHist
20171 #endif
20172 !-----------------------------------------------------------------------------
20173       integer function indmat(i,j)
20174 !el
20175 ! get the position of the jth ijth fragment of the chain coordinate system
20176 ! in the fromto array.
20177       integer :: i,j
20178
20179       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20180       return
20181       end function indmat
20182 !-----------------------------------------------------------------------------
20183       real(kind=8) function sigm(x)
20184 !el
20185        real(kind=8) :: x
20186       sigm=0.25d0*x
20187       return
20188       end function sigm
20189 !-----------------------------------------------------------------------------
20190 !-----------------------------------------------------------------------------
20191       subroutine alloc_ener_arrays
20192 !EL Allocation of arrays used by module energy
20193       use MD_data, only: mset
20194 !el local variables
20195       integer :: i,j
20196
20197       if(nres.lt.100) then
20198       maxconts=10*nres
20199       elseif(nres.lt.200) then
20200       maxconts=10*nres      ! Max. number of contacts per residue
20201       else
20202       maxconts=10*nres ! (maxconts=maxres/4)
20203       endif
20204       maxcont=12*nres      ! Max. number of SC contacts
20205       maxvar=6*nres      ! Max. number of variables
20206 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20207       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20208 !----------------------
20209 ! arrays in subroutine init_int_table
20210 !el#ifdef MPI
20211 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20212 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20213 !el#endif
20214       allocate(nint_gr(nres))
20215       allocate(nscp_gr(nres))
20216       allocate(ielstart(nres))
20217       allocate(ielend(nres))
20218 !(maxres)
20219       allocate(istart(nres,maxint_gr))
20220       allocate(iend(nres,maxint_gr))
20221 !(maxres,maxint_gr)
20222       allocate(iscpstart(nres,maxint_gr))
20223       allocate(iscpend(nres,maxint_gr))
20224 !(maxres,maxint_gr)
20225       allocate(ielstart_vdw(nres))
20226       allocate(ielend_vdw(nres))
20227 !(maxres)
20228       allocate(nint_gr_nucl(nres))
20229       allocate(nscp_gr_nucl(nres))
20230       allocate(ielstart_nucl(nres))
20231       allocate(ielend_nucl(nres))
20232 !(maxres)
20233       allocate(istart_nucl(nres,maxint_gr))
20234       allocate(iend_nucl(nres,maxint_gr))
20235 !(maxres,maxint_gr)
20236       allocate(iscpstart_nucl(nres,maxint_gr))
20237       allocate(iscpend_nucl(nres,maxint_gr))
20238 !(maxres,maxint_gr)
20239       allocate(ielstart_vdw_nucl(nres))
20240       allocate(ielend_vdw_nucl(nres))
20241
20242       allocate(lentyp(0:nfgtasks-1))
20243 !(0:maxprocs-1)
20244 !----------------------
20245 ! commom.contacts
20246 !      common /contacts/
20247       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20248       allocate(icont(2,maxcont))
20249 !(2,maxcont)
20250 !      common /contacts1/
20251       allocate(num_cont(0:nres+4))
20252 !(maxres)
20253       allocate(jcont(maxconts,nres))
20254 !(maxconts,maxres)
20255       allocate(facont(maxconts,nres))
20256 !(maxconts,maxres)
20257       allocate(gacont(3,maxconts,nres))
20258 !(3,maxconts,maxres)
20259 !      common /contacts_hb/
20260       allocate(gacontp_hb1(3,maxconts,nres))
20261       allocate(gacontp_hb2(3,maxconts,nres))
20262       allocate(gacontp_hb3(3,maxconts,nres))
20263       allocate(gacontm_hb1(3,maxconts,nres))
20264       allocate(gacontm_hb2(3,maxconts,nres))
20265       allocate(gacontm_hb3(3,maxconts,nres))
20266       allocate(gacont_hbr(3,maxconts,nres))
20267       allocate(grij_hb_cont(3,maxconts,nres))
20268 !(3,maxconts,maxres)
20269       allocate(facont_hb(maxconts,nres))
20270
20271       allocate(ees0p(maxconts,nres))
20272       allocate(ees0m(maxconts,nres))
20273       allocate(d_cont(maxconts,nres))
20274       allocate(ees0plist(maxconts,nres))
20275
20276 !(maxconts,maxres)
20277       allocate(num_cont_hb(nres))
20278 !(maxres)
20279       allocate(jcont_hb(maxconts,nres))
20280 !(maxconts,maxres)
20281 !      common /rotat/
20282       allocate(Ug(2,2,nres))
20283       allocate(Ugder(2,2,nres))
20284       allocate(Ug2(2,2,nres))
20285       allocate(Ug2der(2,2,nres))
20286 !(2,2,maxres)
20287       allocate(obrot(2,nres))
20288       allocate(obrot2(2,nres))
20289       allocate(obrot_der(2,nres))
20290       allocate(obrot2_der(2,nres))
20291 !(2,maxres)
20292 !      common /precomp1/
20293       allocate(mu(2,nres))
20294       allocate(muder(2,nres))
20295       allocate(Ub2(2,nres))
20296       Ub2(1,:)=0.0d0
20297       Ub2(2,:)=0.0d0
20298       allocate(Ub2der(2,nres))
20299       allocate(Ctobr(2,nres))
20300       allocate(Ctobrder(2,nres))
20301       allocate(Dtobr2(2,nres))
20302       allocate(Dtobr2der(2,nres))
20303 !(2,maxres)
20304       allocate(EUg(2,2,nres))
20305       allocate(EUgder(2,2,nres))
20306       allocate(CUg(2,2,nres))
20307       allocate(CUgder(2,2,nres))
20308       allocate(DUg(2,2,nres))
20309       allocate(Dugder(2,2,nres))
20310       allocate(DtUg2(2,2,nres))
20311       allocate(DtUg2der(2,2,nres))
20312 !(2,2,maxres)
20313 !      common /precomp2/
20314       allocate(Ug2Db1t(2,nres))
20315       allocate(Ug2Db1tder(2,nres))
20316       allocate(CUgb2(2,nres))
20317       allocate(CUgb2der(2,nres))
20318 !(2,maxres)
20319       allocate(EUgC(2,2,nres))
20320       allocate(EUgCder(2,2,nres))
20321       allocate(EUgD(2,2,nres))
20322       allocate(EUgDder(2,2,nres))
20323       allocate(DtUg2EUg(2,2,nres))
20324       allocate(Ug2DtEUg(2,2,nres))
20325 !(2,2,maxres)
20326       allocate(Ug2DtEUgder(2,2,2,nres))
20327       allocate(DtUg2EUgder(2,2,2,nres))
20328 !(2,2,2,maxres)
20329       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20330       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20331       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20332       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20333
20334       allocate(ctilde(2,2,nres))
20335       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20336       allocate(gtb1(2,nres))
20337       allocate(gtb2(2,nres))
20338       allocate(cc(2,2,nres))
20339       allocate(dd(2,2,nres))
20340       allocate(ee(2,2,nres))
20341       allocate(gtcc(2,2,nres))
20342       allocate(gtdd(2,2,nres))
20343       allocate(gtee(2,2,nres))
20344       allocate(gUb2(2,nres))
20345       allocate(gteUg(2,2,nres))
20346
20347 !      common /rotat_old/
20348       allocate(costab(nres))
20349       allocate(sintab(nres))
20350       allocate(costab2(nres))
20351       allocate(sintab2(nres))
20352 !(maxres)
20353 !      common /dipmat/
20354       allocate(a_chuj(2,2,maxconts,nres))
20355 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20356       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20357 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20358 !      common /contdistrib/
20359       allocate(ncont_sent(nres))
20360       allocate(ncont_recv(nres))
20361
20362       allocate(iat_sent(nres))
20363 !(maxres)
20364       allocate(iint_sent(4,nres,nres))
20365       allocate(iint_sent_local(4,nres,nres))
20366 !(4,maxres,maxres)
20367       allocate(iturn3_sent(4,0:nres+4))
20368       allocate(iturn4_sent(4,0:nres+4))
20369       allocate(iturn3_sent_local(4,nres))
20370       allocate(iturn4_sent_local(4,nres))
20371 !(4,maxres)
20372       allocate(itask_cont_from(0:nfgtasks-1))
20373       allocate(itask_cont_to(0:nfgtasks-1))
20374 !(0:max_fg_procs-1)
20375
20376
20377
20378 !----------------------
20379 ! commom.deriv;
20380 !      common /derivat/
20381       allocate(dcdv(6,maxdim))
20382       allocate(dxdv(6,maxdim))
20383 !(6,maxdim)
20384       allocate(dxds(6,nres))
20385 !(6,maxres)
20386       allocate(gradx(3,-1:nres,0:2))
20387       allocate(gradc(3,-1:nres,0:2))
20388 !(3,maxres,2)
20389       allocate(gvdwx(3,-1:nres))
20390       allocate(gvdwc(3,-1:nres))
20391       allocate(gelc(3,-1:nres))
20392       allocate(gelc_long(3,-1:nres))
20393       allocate(gvdwpp(3,-1:nres))
20394       allocate(gvdwc_scpp(3,-1:nres))
20395       allocate(gradx_scp(3,-1:nres))
20396       allocate(gvdwc_scp(3,-1:nres))
20397       allocate(ghpbx(3,-1:nres))
20398       allocate(ghpbc(3,-1:nres))
20399       allocate(gradcorr(3,-1:nres))
20400       allocate(gradcorr_long(3,-1:nres))
20401       allocate(gradcorr5_long(3,-1:nres))
20402       allocate(gradcorr6_long(3,-1:nres))
20403       allocate(gcorr6_turn_long(3,-1:nres))
20404       allocate(gradxorr(3,-1:nres))
20405       allocate(gradcorr5(3,-1:nres))
20406       allocate(gradcorr6(3,-1:nres))
20407       allocate(gliptran(3,-1:nres))
20408       allocate(gliptranc(3,-1:nres))
20409       allocate(gliptranx(3,-1:nres))
20410       allocate(gshieldx(3,-1:nres))
20411       allocate(gshieldc(3,-1:nres))
20412       allocate(gshieldc_loc(3,-1:nres))
20413       allocate(gshieldx_ec(3,-1:nres))
20414       allocate(gshieldc_ec(3,-1:nres))
20415       allocate(gshieldc_loc_ec(3,-1:nres))
20416       allocate(gshieldx_t3(3,-1:nres))
20417       allocate(gshieldc_t3(3,-1:nres))
20418       allocate(gshieldc_loc_t3(3,-1:nres))
20419       allocate(gshieldx_t4(3,-1:nres))
20420       allocate(gshieldc_t4(3,-1:nres))
20421       allocate(gshieldc_loc_t4(3,-1:nres))
20422       allocate(gshieldx_ll(3,-1:nres))
20423       allocate(gshieldc_ll(3,-1:nres))
20424       allocate(gshieldc_loc_ll(3,-1:nres))
20425       allocate(grad_shield(3,-1:nres))
20426       allocate(gg_tube_sc(3,-1:nres))
20427       allocate(gg_tube(3,-1:nres))
20428       allocate(gradafm(3,-1:nres))
20429       allocate(gradb_nucl(3,-1:nres))
20430       allocate(gradbx_nucl(3,-1:nres))
20431       allocate(gvdwpsb1(3,-1:nres))
20432       allocate(gelpp(3,-1:nres))
20433       allocate(gvdwpsb(3,-1:nres))
20434       allocate(gelsbc(3,-1:nres))
20435       allocate(gelsbx(3,-1:nres))
20436       allocate(gvdwsbx(3,-1:nres))
20437       allocate(gvdwsbc(3,-1:nres))
20438       allocate(gsbloc(3,-1:nres))
20439       allocate(gsblocx(3,-1:nres))
20440       allocate(gradcorr_nucl(3,-1:nres))
20441       allocate(gradxorr_nucl(3,-1:nres))
20442       allocate(gradcorr3_nucl(3,-1:nres))
20443       allocate(gradxorr3_nucl(3,-1:nres))
20444       allocate(gvdwpp_nucl(3,-1:nres))
20445       allocate(gradpepcat(3,-1:nres))
20446       allocate(gradpepcatx(3,-1:nres))
20447       allocate(gradcatcat(3,-1:nres))
20448       allocate(gradnuclcat(3,-1:nres))
20449       allocate(gradnuclcatx(3,-1:nres))
20450 !(3,maxres)
20451       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20452       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20453 ! grad for shielding surroing
20454       allocate(gloc(0:maxvar,0:2))
20455       allocate(gloc_x(0:maxvar,2))
20456 !(maxvar,2)
20457       allocate(gel_loc(3,-1:nres))
20458       allocate(gel_loc_long(3,-1:nres))
20459       allocate(gcorr3_turn(3,-1:nres))
20460       allocate(gcorr4_turn(3,-1:nres))
20461       allocate(gcorr6_turn(3,-1:nres))
20462       allocate(gradb(3,-1:nres))
20463       allocate(gradbx(3,-1:nres))
20464 !(3,maxres)
20465       allocate(gel_loc_loc(maxvar))
20466       allocate(gel_loc_turn3(maxvar))
20467       allocate(gel_loc_turn4(maxvar))
20468       allocate(gel_loc_turn6(maxvar))
20469       allocate(gcorr_loc(maxvar))
20470       allocate(g_corr5_loc(maxvar))
20471       allocate(g_corr6_loc(maxvar))
20472 !(maxvar)
20473       allocate(gsccorc(3,-1:nres))
20474       allocate(gsccorx(3,-1:nres))
20475 !(3,maxres)
20476       allocate(gsccor_loc(-1:nres))
20477 !(maxres)
20478       allocate(gvdwx_scbase(3,-1:nres))
20479       allocate(gvdwc_scbase(3,-1:nres))
20480       allocate(gvdwx_pepbase(3,-1:nres))
20481       allocate(gvdwc_pepbase(3,-1:nres))
20482       allocate(gvdwx_scpho(3,-1:nres))
20483       allocate(gvdwc_scpho(3,-1:nres))
20484       allocate(gvdwc_peppho(3,-1:nres))
20485
20486       allocate(dtheta(3,2,-1:nres))
20487 !(3,2,maxres)
20488       allocate(gscloc(3,-1:nres))
20489       allocate(gsclocx(3,-1:nres))
20490 !(3,maxres)
20491       allocate(dphi(3,3,-1:nres))
20492       allocate(dalpha(3,3,-1:nres))
20493       allocate(domega(3,3,-1:nres))
20494 !(3,3,maxres)
20495 !      common /deriv_scloc/
20496       allocate(dXX_C1tab(3,nres))
20497       allocate(dYY_C1tab(3,nres))
20498       allocate(dZZ_C1tab(3,nres))
20499       allocate(dXX_Ctab(3,nres))
20500       allocate(dYY_Ctab(3,nres))
20501       allocate(dZZ_Ctab(3,nres))
20502       allocate(dXX_XYZtab(3,nres))
20503       allocate(dYY_XYZtab(3,nres))
20504       allocate(dZZ_XYZtab(3,nres))
20505 !(3,maxres)
20506 !      common /mpgrad/
20507       allocate(jgrad_start(nres))
20508       allocate(jgrad_end(nres))
20509 !(maxres)
20510 !----------------------
20511
20512 !      common /indices/
20513       allocate(ibond_displ(0:nfgtasks-1))
20514       allocate(ibond_count(0:nfgtasks-1))
20515       allocate(ithet_displ(0:nfgtasks-1))
20516       allocate(ithet_count(0:nfgtasks-1))
20517       allocate(iphi_displ(0:nfgtasks-1))
20518       allocate(iphi_count(0:nfgtasks-1))
20519       allocate(iphi1_displ(0:nfgtasks-1))
20520       allocate(iphi1_count(0:nfgtasks-1))
20521       allocate(ivec_displ(0:nfgtasks-1))
20522       allocate(ivec_count(0:nfgtasks-1))
20523       allocate(iset_displ(0:nfgtasks-1))
20524       allocate(iset_count(0:nfgtasks-1))
20525       allocate(iint_count(0:nfgtasks-1))
20526       allocate(iint_displ(0:nfgtasks-1))
20527 !(0:max_fg_procs-1)
20528 !----------------------
20529 ! common.MD
20530 !      common /mdgrad/
20531       allocate(gcart(3,-1:nres))
20532       allocate(gxcart(3,-1:nres))
20533 !(3,0:MAXRES)
20534       allocate(gradcag(3,-1:nres))
20535       allocate(gradxag(3,-1:nres))
20536 !(3,MAXRES)
20537 !      common /back_constr/
20538 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20539       allocate(dutheta(nres))
20540       allocate(dugamma(nres))
20541 !(maxres)
20542       allocate(duscdiff(3,nres))
20543       allocate(duscdiffx(3,nres))
20544 !(3,maxres)
20545 !el i io:read_fragments
20546 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20547 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20548 !      common /qmeas/
20549 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20550 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20551       allocate(mset(0:nprocs))  !(maxprocs/20)
20552       mset(:)=0
20553 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20554 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20555       allocate(dUdconst(3,0:nres))
20556       allocate(dUdxconst(3,0:nres))
20557       allocate(dqwol(3,0:nres))
20558       allocate(dxqwol(3,0:nres))
20559 !(3,0:MAXRES)
20560 !----------------------
20561 ! common.sbridge
20562 !      common /sbridge/ in io_common: read_bridge
20563 !el    allocate((:),allocatable :: iss      !(maxss)
20564 !      common /links/  in io_common: read_bridge
20565 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20566 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20567 !      common /dyn_ssbond/
20568 ! and side-chain vectors in theta or phi.
20569       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20570 !(maxres,maxres)
20571 !      do i=1,nres
20572 !        do j=i+1,nres
20573       dyn_ssbond_ij(:,:)=1.0d300
20574 !        enddo
20575 !      enddo
20576
20577 !      if (nss.gt.0) then
20578       allocate(idssb(maxdim),jdssb(maxdim))
20579 !        allocate(newihpb(nss),newjhpb(nss))
20580 !(maxdim)
20581 !      endif
20582       allocate(ishield_list(-1:nres))
20583       allocate(shield_list(maxcontsshi,-1:nres))
20584       allocate(dyn_ss_mask(nres))
20585       allocate(fac_shield(-1:nres))
20586       allocate(enetube(nres*2))
20587       allocate(enecavtube(nres*2))
20588
20589 !(maxres)
20590       dyn_ss_mask(:)=.false.
20591 !----------------------
20592 ! common.sccor
20593 ! Parameters of the SCCOR term
20594 !      common/sccor/
20595 !el in io_conf: parmread
20596 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20597 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20598 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20599 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20600 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20601 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20602 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20603 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20604 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20605 !----------------
20606       allocate(gloc_sc(3,0:2*nres,0:10))
20607 !(3,0:maxres2,10)maxres2=2*maxres
20608       allocate(dcostau(3,3,3,2*nres))
20609       allocate(dsintau(3,3,3,2*nres))
20610       allocate(dtauangle(3,3,3,2*nres))
20611       allocate(dcosomicron(3,3,3,2*nres))
20612       allocate(domicron(3,3,3,2*nres))
20613 !(3,3,3,maxres2)maxres2=2*maxres
20614 !----------------------
20615 ! common.var
20616 !      common /restr/
20617       allocate(varall(maxvar))
20618 !(maxvar)(maxvar=6*maxres)
20619       allocate(mask_theta(nres))
20620       allocate(mask_phi(nres))
20621       allocate(mask_side(nres))
20622 !(maxres)
20623 !----------------------
20624 ! common.vectors
20625 !      common /vectors/
20626       allocate(uy(3,nres))
20627       allocate(uz(3,nres))
20628 !(3,maxres)
20629       allocate(uygrad(3,3,2,nres))
20630       allocate(uzgrad(3,3,2,nres))
20631 !(3,3,2,maxres)
20632 ! allocateion of lists JPRDLA
20633       allocate(newcontlistppi(300*nres))
20634       allocate(newcontlistscpi(350*nres))
20635       allocate(newcontlisti(300*nres))
20636       allocate(newcontlistppj(300*nres))
20637       allocate(newcontlistscpj(350*nres))
20638       allocate(newcontlistj(300*nres))
20639
20640       return
20641       end subroutine alloc_ener_arrays
20642 !-----------------------------------------------------------------
20643       subroutine ebond_nucl(estr_nucl)
20644 !c
20645 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20646 !c
20647
20648       real(kind=8),dimension(3) :: u,ud
20649       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20650       real(kind=8) :: estr_nucl,diff
20651       integer :: iti,i,j,k,nbi
20652       estr_nucl=0.0d0
20653 !C      print *,"I enter ebond"
20654       if (energy_dec) &
20655       write (iout,*) "ibondp_start,ibondp_end",&
20656        ibondp_nucl_start,ibondp_nucl_end
20657       do i=ibondp_nucl_start,ibondp_nucl_end
20658       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20659        itype(i,2).eq.ntyp1_molec(2)) cycle
20660 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20661 !          do j=1,3
20662 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20663 !     &      *dc(j,i-1)/vbld(i)
20664 !          enddo
20665 !          if (energy_dec) write(iout,*)
20666 !     &       "estr1",i,vbld(i),distchainmax,
20667 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20668
20669         diff = vbld(i)-vbldp0_nucl
20670         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20671         vbldp0_nucl,diff,AKP_nucl*diff*diff
20672         estr_nucl=estr_nucl+diff*diff
20673 !          print *,estr_nucl
20674         do j=1,3
20675           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20676         enddo
20677 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20678       enddo
20679       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20680 !      print *,"partial sum", estr_nucl,AKP_nucl
20681
20682       if (energy_dec) &
20683       write (iout,*) "ibondp_start,ibondp_end",&
20684        ibond_nucl_start,ibond_nucl_end
20685
20686       do i=ibond_nucl_start,ibond_nucl_end
20687 !C        print *, "I am stuck",i
20688       iti=itype(i,2)
20689       if (iti.eq.ntyp1_molec(2)) cycle
20690         nbi=nbondterm_nucl(iti)
20691 !C        print *,iti,nbi
20692         if (nbi.eq.1) then
20693           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20694
20695           if (energy_dec) &
20696          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20697          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20698           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20699 !            print *,estr_nucl
20700           do j=1,3
20701             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20702           enddo
20703         else
20704           do j=1,nbi
20705             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20706             ud(j)=aksc_nucl(j,iti)*diff
20707             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20708           enddo
20709           uprod=u(1)
20710           do j=2,nbi
20711             uprod=uprod*u(j)
20712           enddo
20713           usum=0.0d0
20714           usumsqder=0.0d0
20715           do j=1,nbi
20716             uprod1=1.0d0
20717             uprod2=1.0d0
20718             do k=1,nbi
20719             if (k.ne.j) then
20720               uprod1=uprod1*u(k)
20721               uprod2=uprod2*u(k)*u(k)
20722             endif
20723             enddo
20724             usum=usum+uprod1
20725             usumsqder=usumsqder+ud(j)*uprod2
20726           enddo
20727           estr_nucl=estr_nucl+uprod/usum
20728           do j=1,3
20729            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20730           enddo
20731       endif
20732       enddo
20733 !C      print *,"I am about to leave ebond"
20734       return
20735       end subroutine ebond_nucl
20736
20737 !-----------------------------------------------------------------------------
20738       subroutine ebend_nucl(etheta_nucl)
20739       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20740       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20741       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20742       logical :: lprn=.false., lprn1=.false.
20743 !el local variables
20744       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20745       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20746       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20747 ! local variables for constrains
20748       real(kind=8) :: difi,thetiii
20749        integer itheta
20750       etheta_nucl=0.0D0
20751 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20752       do i=ithet_nucl_start,ithet_nucl_end
20753       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20754       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20755       (itype(i,2).eq.ntyp1_molec(2))) cycle
20756       dethetai=0.0d0
20757       dephii=0.0d0
20758       dephii1=0.0d0
20759       theti2=0.5d0*theta(i)
20760       ityp2=ithetyp_nucl(itype(i-1,2))
20761       do k=1,nntheterm_nucl
20762         coskt(k)=dcos(k*theti2)
20763         sinkt(k)=dsin(k*theti2)
20764       enddo
20765       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20766 #ifdef OSF
20767         phii=phi(i)
20768         if (phii.ne.phii) phii=150.0
20769 #else
20770         phii=phi(i)
20771 #endif
20772         ityp1=ithetyp_nucl(itype(i-2,2))
20773         do k=1,nsingle_nucl
20774           cosph1(k)=dcos(k*phii)
20775           sinph1(k)=dsin(k*phii)
20776         enddo
20777       else
20778         phii=0.0d0
20779         ityp1=nthetyp_nucl+1
20780         do k=1,nsingle_nucl
20781           cosph1(k)=0.0d0
20782           sinph1(k)=0.0d0
20783         enddo
20784       endif
20785
20786       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20787 #ifdef OSF
20788         phii1=phi(i+1)
20789         if (phii1.ne.phii1) phii1=150.0
20790         phii1=pinorm(phii1)
20791 #else
20792         phii1=phi(i+1)
20793 #endif
20794         ityp3=ithetyp_nucl(itype(i,2))
20795         do k=1,nsingle_nucl
20796           cosph2(k)=dcos(k*phii1)
20797           sinph2(k)=dsin(k*phii1)
20798         enddo
20799       else
20800         phii1=0.0d0
20801         ityp3=nthetyp_nucl+1
20802         do k=1,nsingle_nucl
20803           cosph2(k)=0.0d0
20804           sinph2(k)=0.0d0
20805         enddo
20806       endif
20807       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20808       do k=1,ndouble_nucl
20809         do l=1,k-1
20810           ccl=cosph1(l)*cosph2(k-l)
20811           ssl=sinph1(l)*sinph2(k-l)
20812           scl=sinph1(l)*cosph2(k-l)
20813           csl=cosph1(l)*sinph2(k-l)
20814           cosph1ph2(l,k)=ccl-ssl
20815           cosph1ph2(k,l)=ccl+ssl
20816           sinph1ph2(l,k)=scl+csl
20817           sinph1ph2(k,l)=scl-csl
20818         enddo
20819       enddo
20820       if (lprn) then
20821       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20822        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20823       write (iout,*) "coskt and sinkt",nntheterm_nucl
20824       do k=1,nntheterm_nucl
20825         write (iout,*) k,coskt(k),sinkt(k)
20826       enddo
20827       endif
20828       do k=1,ntheterm_nucl
20829         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20830         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20831          *coskt(k)
20832         if (lprn)&
20833        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20834         " ethetai",ethetai
20835       enddo
20836       if (lprn) then
20837       write (iout,*) "cosph and sinph"
20838       do k=1,nsingle_nucl
20839         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20840       enddo
20841       write (iout,*) "cosph1ph2 and sinph2ph2"
20842       do k=2,ndouble_nucl
20843         do l=1,k-1
20844           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20845             sinph1ph2(l,k),sinph1ph2(k,l)
20846         enddo
20847       enddo
20848       write(iout,*) "ethetai",ethetai
20849       endif
20850       do m=1,ntheterm2_nucl
20851         do k=1,nsingle_nucl
20852           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20853             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20854             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20855             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20856           ethetai=ethetai+sinkt(m)*aux
20857           dethetai=dethetai+0.5d0*m*aux*coskt(m)
20858           dephii=dephii+k*sinkt(m)*(&
20859              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20860              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20861           dephii1=dephii1+k*sinkt(m)*(&
20862              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20863              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20864           if (lprn) &
20865          write (iout,*) "m",m," k",k," bbthet",&
20866             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20867             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20868             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20869             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20870         enddo
20871       enddo
20872       if (lprn) &
20873       write(iout,*) "ethetai",ethetai
20874       do m=1,ntheterm3_nucl
20875         do k=2,ndouble_nucl
20876           do l=1,k-1
20877             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20878              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20879              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20880              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20881             ethetai=ethetai+sinkt(m)*aux
20882             dethetai=dethetai+0.5d0*m*coskt(m)*aux
20883             dephii=dephii+l*sinkt(m)*(&
20884             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20885              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20886              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20887              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20888             dephii1=dephii1+(k-l)*sinkt(m)*( &
20889             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20890              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20891              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20892              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20893             if (lprn) then
20894             write (iout,*) "m",m," k",k," l",l," ffthet", &
20895              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20896              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20897              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20898              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20899             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20900              cosph1ph2(k,l)*sinkt(m),&
20901              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20902             endif
20903           enddo
20904         enddo
20905       enddo
20906 10      continue
20907       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20908       i,theta(i)*rad2deg,phii*rad2deg, &
20909       phii1*rad2deg,ethetai
20910       etheta_nucl=etheta_nucl+ethetai
20911 !        print *,i,"partial sum",etheta_nucl
20912       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20913       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20914       gloc(nphi+i-2,icg)=wang_nucl*dethetai
20915       enddo
20916       return
20917       end subroutine ebend_nucl
20918 !----------------------------------------------------
20919       subroutine etor_nucl(etors_nucl)
20920 !      implicit real*8 (a-h,o-z)
20921 !      include 'DIMENSIONS'
20922 !      include 'COMMON.VAR'
20923 !      include 'COMMON.GEO'
20924 !      include 'COMMON.LOCAL'
20925 !      include 'COMMON.TORSION'
20926 !      include 'COMMON.INTERACT'
20927 !      include 'COMMON.DERIV'
20928 !      include 'COMMON.CHAIN'
20929 !      include 'COMMON.NAMES'
20930 !      include 'COMMON.IOUNITS'
20931 !      include 'COMMON.FFIELD'
20932 !      include 'COMMON.TORCNSTR'
20933 !      include 'COMMON.CONTROL'
20934       real(kind=8) :: etors_nucl,edihcnstr
20935       logical :: lprn
20936 !el local variables
20937       integer :: i,j,iblock,itori,itori1
20938       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20939                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20940 ! Set lprn=.true. for debugging
20941       lprn=.false.
20942 !     lprn=.true.
20943       etors_nucl=0.0D0
20944 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20945       do i=iphi_nucl_start,iphi_nucl_end
20946       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20947            .or. itype(i-3,2).eq.ntyp1_molec(2) &
20948            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20949       etors_ii=0.0D0
20950       itori=itortyp_nucl(itype(i-2,2))
20951       itori1=itortyp_nucl(itype(i-1,2))
20952       phii=phi(i)
20953 !         print *,i,itori,itori1
20954       gloci=0.0D0
20955 !C Regular cosine and sine terms
20956       do j=1,nterm_nucl(itori,itori1)
20957         v1ij=v1_nucl(j,itori,itori1)
20958         v2ij=v2_nucl(j,itori,itori1)
20959         cosphi=dcos(j*phii)
20960         sinphi=dsin(j*phii)
20961         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20962         if (energy_dec) etors_ii=etors_ii+&
20963                  v1ij*cosphi+v2ij*sinphi
20964         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20965       enddo
20966 !C Lorentz terms
20967 !C                         v1
20968 !C  E = SUM ----------------------------------- - v1
20969 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20970 !C
20971       cosphi=dcos(0.5d0*phii)
20972       sinphi=dsin(0.5d0*phii)
20973       do j=1,nlor_nucl(itori,itori1)
20974         vl1ij=vlor1_nucl(j,itori,itori1)
20975         vl2ij=vlor2_nucl(j,itori,itori1)
20976         vl3ij=vlor3_nucl(j,itori,itori1)
20977         pom=vl2ij*cosphi+vl3ij*sinphi
20978         pom1=1.0d0/(pom*pom+1.0d0)
20979         etors_nucl=etors_nucl+vl1ij*pom1
20980         if (energy_dec) etors_ii=etors_ii+ &
20981                  vl1ij*pom1
20982         pom=-pom*pom1*pom1
20983         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20984       enddo
20985 !C Subtract the constant term
20986       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20987         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20988             'etor',i,etors_ii-v0_nucl(itori,itori1)
20989       if (lprn) &
20990        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20991        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20992        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20993       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20994 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20995       enddo
20996       return
20997       end subroutine etor_nucl
20998 !------------------------------------------------------------
20999       subroutine epp_nucl_sub(evdw1,ees)
21000 !C
21001 !C This subroutine calculates the average interaction energy and its gradient
21002 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21003 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21004 !C The potential depends both on the distance of peptide-group centers and on
21005 !C the orientation of the CA-CA virtual bonds.
21006 !C
21007       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21008       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
21009                       sslipj,ssgradlipj,faclipij2
21010       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21011              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21012              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21013       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21014                 dist_temp, dist_init,sss_grad,fac,evdw1ij
21015       integer xshift,yshift,zshift
21016       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21017       real(kind=8) :: ees,eesij
21018 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21019       real(kind=8) scal_el /0.5d0/
21020       t_eelecij=0.0d0
21021       ees=0.0D0
21022       evdw1=0.0D0
21023       ind=0
21024 !c
21025 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21026 !c
21027 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21028       do i=iatel_s_nucl,iatel_e_nucl
21029       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21030       dxi=dc(1,i)
21031       dyi=dc(2,i)
21032       dzi=dc(3,i)
21033       dx_normi=dc_norm(1,i)
21034       dy_normi=dc_norm(2,i)
21035       dz_normi=dc_norm(3,i)
21036       xmedi=c(1,i)+0.5d0*dxi
21037       ymedi=c(2,i)+0.5d0*dyi
21038       zmedi=c(3,i)+0.5d0*dzi
21039         call to_box(xmedi,ymedi,zmedi)
21040         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
21041
21042       do j=ielstart_nucl(i),ielend_nucl(i)
21043         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21044         ind=ind+1
21045         dxj=dc(1,j)
21046         dyj=dc(2,j)
21047         dzj=dc(3,j)
21048 !          xj=c(1,j)+0.5D0*dxj-xmedi
21049 !          yj=c(2,j)+0.5D0*dyj-ymedi
21050 !          zj=c(3,j)+0.5D0*dzj-zmedi
21051         xj=c(1,j)+0.5D0*dxj
21052         yj=c(2,j)+0.5D0*dyj
21053         zj=c(3,j)+0.5D0*dzj
21054      call to_box(xj,yj,zj)
21055      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21056       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
21057       xj=boxshift(xj-xmedi,boxxsize)
21058       yj=boxshift(yj-ymedi,boxysize)
21059       zj=boxshift(zj-zmedi,boxzsize)
21060         rij=xj*xj+yj*yj+zj*zj
21061 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21062         fac=(r0pp**2/rij)**3
21063         ev1=epspp*fac*fac
21064         ev2=epspp*fac
21065         evdw1ij=ev1-2*ev2
21066         fac=(-ev1-evdw1ij)/rij
21067 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21068         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21069         evdw1=evdw1+evdw1ij
21070 !C
21071 !C Calculate contributions to the Cartesian gradient.
21072 !C
21073         ggg(1)=fac*xj
21074         ggg(2)=fac*yj
21075         ggg(3)=fac*zj
21076         do k=1,3
21077           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21078           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21079         enddo
21080 !c phoshate-phosphate electrostatic interactions
21081         rij=dsqrt(rij)
21082         fac=1.0d0/rij
21083         eesij=dexp(-BEES*rij)*fac
21084 !          write (2,*)"fac",fac," eesijpp",eesij
21085         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21086         ees=ees+eesij
21087 !c          fac=-eesij*fac
21088         fac=-(fac+BEES)*eesij*fac
21089         ggg(1)=fac*xj
21090         ggg(2)=fac*yj
21091         ggg(3)=fac*zj
21092 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21093 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21094 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21095         do k=1,3
21096           gelpp(k,i)=gelpp(k,i)-ggg(k)
21097           gelpp(k,j)=gelpp(k,j)+ggg(k)
21098         enddo
21099       enddo ! j
21100       enddo   ! i
21101 !c      ees=332.0d0*ees
21102       ees=AEES*ees
21103       do i=nnt,nct
21104 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21105       do k=1,3
21106         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21107 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21108         gelpp(k,i)=AEES*gelpp(k,i)
21109       enddo
21110 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21111       enddo
21112 !c      write (2,*) "total EES",ees
21113       return
21114       end subroutine epp_nucl_sub
21115 !---------------------------------------------------------------------
21116       subroutine epsb(evdwpsb,eelpsb)
21117 !      use comm_locel
21118 !C
21119 !C This subroutine calculates the excluded-volume interaction energy between
21120 !C peptide-group centers and side chains and its gradient in virtual-bond and
21121 !C side-chain vectors.
21122 !C
21123       real(kind=8),dimension(3):: ggg
21124       integer :: i,iint,j,k,iteli,itypj,subchap
21125       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21126                e1,e2,evdwij,rij,evdwpsb,eelpsb
21127       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21128                 dist_temp, dist_init
21129       integer xshift,yshift,zshift
21130
21131 !cd    print '(a)','Enter ESCP'
21132 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21133       eelpsb=0.0d0
21134       evdwpsb=0.0d0
21135 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21136       do i=iatscp_s_nucl,iatscp_e_nucl
21137       if (itype(i,2).eq.ntyp1_molec(2) &
21138        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21139       xi=0.5D0*(c(1,i)+c(1,i+1))
21140       yi=0.5D0*(c(2,i)+c(2,i+1))
21141       zi=0.5D0*(c(3,i)+c(3,i+1))
21142         call to_box(xi,yi,zi)
21143
21144       do iint=1,nscp_gr_nucl(i)
21145
21146       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21147         itypj=itype(j,2)
21148         if (itypj.eq.ntyp1_molec(2)) cycle
21149 !C Uncomment following three lines for SC-p interactions
21150 !c         xj=c(1,nres+j)-xi
21151 !c         yj=c(2,nres+j)-yi
21152 !c         zj=c(3,nres+j)-zi
21153 !C Uncomment following three lines for Ca-p interactions
21154 !          xj=c(1,j)-xi
21155 !          yj=c(2,j)-yi
21156 !          zj=c(3,j)-zi
21157         xj=c(1,j)
21158         yj=c(2,j)
21159         zj=c(3,j)
21160         call to_box(xj,yj,zj)
21161       xj=boxshift(xj-xi,boxxsize)
21162       yj=boxshift(yj-yi,boxysize)
21163       zj=boxshift(zj-zi,boxzsize)
21164
21165       dist_init=xj**2+yj**2+zj**2
21166
21167         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21168         fac=rrij**expon2
21169         e1=fac*fac*aad_nucl(itypj)
21170         e2=fac*bad_nucl(itypj)
21171         if (iabs(j-i) .le. 2) then
21172           e1=scal14*e1
21173           e2=scal14*e2
21174         endif
21175         evdwij=e1+e2
21176         evdwpsb=evdwpsb+evdwij
21177         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21178            'evdw2',i,j,evdwij,"tu4"
21179 !C
21180 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21181 !C
21182         fac=-(evdwij+e1)*rrij
21183         ggg(1)=xj*fac
21184         ggg(2)=yj*fac
21185         ggg(3)=zj*fac
21186         do k=1,3
21187           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21188           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21189         enddo
21190       enddo
21191
21192       enddo ! iint
21193       enddo ! i
21194       do i=1,nct
21195       do j=1,3
21196         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21197         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21198       enddo
21199       enddo
21200       return
21201       end subroutine epsb
21202
21203 !------------------------------------------------------
21204       subroutine esb_gb(evdwsb,eelsb)
21205       use comm_locel
21206       use calc_data_nucl
21207       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21208       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21209       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21210       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21211                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21212       integer :: ii
21213       logical lprn
21214       evdw=0.0D0
21215       eelsb=0.0d0
21216       ecorr=0.0d0
21217       evdwsb=0.0D0
21218       lprn=.false.
21219       ind=0
21220 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21221       do i=iatsc_s_nucl,iatsc_e_nucl
21222       num_conti=0
21223       num_conti2=0
21224       itypi=itype(i,2)
21225 !        PRINT *,"I=",i,itypi
21226       if (itypi.eq.ntyp1_molec(2)) cycle
21227       itypi1=itype(i+1,2)
21228       xi=c(1,nres+i)
21229       yi=c(2,nres+i)
21230       zi=c(3,nres+i)
21231       call to_box(xi,yi,zi)
21232       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21233       dxi=dc_norm(1,nres+i)
21234       dyi=dc_norm(2,nres+i)
21235       dzi=dc_norm(3,nres+i)
21236       dsci_inv=vbld_inv(i+nres)
21237 !C
21238 !C Calculate SC interaction energy.
21239 !C
21240       do iint=1,nint_gr_nucl(i)
21241 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21242         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21243           ind=ind+1
21244 !            print *,"JESTEM"
21245           itypj=itype(j,2)
21246           if (itypj.eq.ntyp1_molec(2)) cycle
21247           dscj_inv=vbld_inv(j+nres)
21248           sig0ij=sigma_nucl(itypi,itypj)
21249           chi1=chi_nucl(itypi,itypj)
21250           chi2=chi_nucl(itypj,itypi)
21251           chi12=chi1*chi2
21252           chip1=chip_nucl(itypi,itypj)
21253           chip2=chip_nucl(itypj,itypi)
21254           chip12=chip1*chip2
21255 !            xj=c(1,nres+j)-xi
21256 !            yj=c(2,nres+j)-yi
21257 !            zj=c(3,nres+j)-zi
21258          xj=c(1,nres+j)
21259          yj=c(2,nres+j)
21260          zj=c(3,nres+j)
21261      call to_box(xj,yj,zj)
21262 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21263 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21264 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21265 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21266 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21267       xj=boxshift(xj-xi,boxxsize)
21268       yj=boxshift(yj-yi,boxysize)
21269       zj=boxshift(zj-zi,boxzsize)
21270
21271           dxj=dc_norm(1,nres+j)
21272           dyj=dc_norm(2,nres+j)
21273           dzj=dc_norm(3,nres+j)
21274           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21275           rij=dsqrt(rrij)
21276 !C Calculate angle-dependent terms of energy and contributions to their
21277 !C derivatives.
21278           erij(1)=xj*rij
21279           erij(2)=yj*rij
21280           erij(3)=zj*rij
21281           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21282           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21283           om12=dxi*dxj+dyi*dyj+dzi*dzj
21284           call sc_angular_nucl
21285           sigsq=1.0D0/sigsq
21286           sig=sig0ij*dsqrt(sigsq)
21287           rij_shift=1.0D0/rij-sig+sig0ij
21288 !            print *,rij_shift,"rij_shift"
21289 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21290 !c     &       " rij_shift",rij_shift
21291           if (rij_shift.le.0.0D0) then
21292             evdw=1.0D20
21293             return
21294           endif
21295           sigder=-sig*sigsq
21296 !c---------------------------------------------------------------
21297           rij_shift=1.0D0/rij_shift
21298           fac=rij_shift**expon
21299           e1=fac*fac*aa_nucl(itypi,itypj)
21300           e2=fac*bb_nucl(itypi,itypj)
21301           evdwij=eps1*eps2rt*(e1+e2)
21302 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21303 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21304           eps2der=evdwij
21305           evdwij=evdwij*eps2rt
21306           evdwsb=evdwsb+evdwij
21307           if (lprn) then
21308           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21309           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21310           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21311            restyp(itypi,2),i,restyp(itypj,2),j, &
21312            epsi,sigm,chi1,chi2,chip1,chip2, &
21313            eps1,eps2rt**2,sig,sig0ij, &
21314            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21315           evdwij
21316           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21317           endif
21318
21319           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21320                        'evdw',i,j,evdwij,"tu3"
21321
21322
21323 !C Calculate gradient components.
21324           e1=e1*eps1*eps2rt**2
21325           fac=-expon*(e1+evdwij)*rij_shift
21326           sigder=fac*sigder
21327           fac=rij*fac
21328 !c            fac=0.0d0
21329 !C Calculate the radial part of the gradient
21330           gg(1)=xj*fac
21331           gg(2)=yj*fac
21332           gg(3)=zj*fac
21333 !C Calculate angular part of the gradient.
21334           call sc_grad_nucl
21335           call eelsbij(eelij,num_conti2)
21336           if (energy_dec .and. &
21337          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21338         write (istat,'(e14.5)') evdwij
21339           eelsb=eelsb+eelij
21340         enddo      ! j
21341       enddo        ! iint
21342       num_cont_hb(i)=num_conti2
21343       enddo          ! i
21344 !c      write (iout,*) "Number of loop steps in EGB:",ind
21345 !cccc      energy_dec=.false.
21346       return
21347       end subroutine esb_gb
21348 !-------------------------------------------------------------------------------
21349       subroutine eelsbij(eesij,num_conti2)
21350       use comm_locel
21351       use calc_data_nucl
21352       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21353       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21354       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21355                 dist_temp, dist_init,rlocshield,fracinbuf
21356       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21357
21358 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21359       real(kind=8) scal_el /0.5d0/
21360       integer :: iteli,itelj,kkk,kkll,m,isubchap
21361       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21362       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21363       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21364               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21365               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21366               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21367               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21368               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21369               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21370               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21371       ind=ind+1
21372       itypi=itype(i,2)
21373       itypj=itype(j,2)
21374 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21375       ael6i=ael6_nucl(itypi,itypj)
21376       ael3i=ael3_nucl(itypi,itypj)
21377       ael63i=ael63_nucl(itypi,itypj)
21378       ael32i=ael32_nucl(itypi,itypj)
21379 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21380 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21381       dxj=dc(1,j+nres)
21382       dyj=dc(2,j+nres)
21383       dzj=dc(3,j+nres)
21384       dx_normi=dc_norm(1,i+nres)
21385       dy_normi=dc_norm(2,i+nres)
21386       dz_normi=dc_norm(3,i+nres)
21387       dx_normj=dc_norm(1,j+nres)
21388       dy_normj=dc_norm(2,j+nres)
21389       dz_normj=dc_norm(3,j+nres)
21390 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21391 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21392 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21393       if (ipot_nucl.ne.2) then
21394       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21395       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21396       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21397       else
21398       cosa=om12
21399       cosb=om1
21400       cosg=om2
21401       endif
21402       r3ij=rij*rrij
21403       r6ij=r3ij*r3ij
21404       fac=cosa-3.0D0*cosb*cosg
21405       facfac=fac*fac
21406       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21407       fac3=ael6i*r6ij
21408       fac4=ael3i*r3ij
21409       fac5=ael63i*r6ij
21410       fac6=ael32i*r6ij
21411 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21412 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21413       el1=fac3*(4.0D0+facfac-fac1)
21414       el2=fac4*fac
21415       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21416       el4=fac6*facfac
21417       eesij=el1+el2+el3+el4
21418 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21419       ees0ij=4.0D0+facfac-fac1
21420
21421       if (energy_dec) then
21422         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21423         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21424          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21425          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21426          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21427         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21428       endif
21429
21430 !C
21431 !C Calculate contributions to the Cartesian gradient.
21432 !C
21433       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21434       fac1=fac
21435 !c      erij(1)=xj*rmij
21436 !c      erij(2)=yj*rmij
21437 !c      erij(3)=zj*rmij
21438 !*
21439 !* Radial derivatives. First process both termini of the fragment (i,j)
21440 !*
21441       ggg(1)=facel*xj
21442       ggg(2)=facel*yj
21443       ggg(3)=facel*zj
21444       do k=1,3
21445       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21446       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21447       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21448       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21449       enddo
21450 !*
21451 !* Angular part
21452 !*
21453       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21454       fac4=-3.0D0*fac4
21455       fac3=-6.0D0*fac3
21456       fac5= 6.0d0*fac5
21457       fac6=-6.0d0*fac6
21458       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21459        fac6*fac1*cosg
21460       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21461        fac6*fac1*cosb
21462       do k=1,3
21463       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21464       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21465       enddo
21466       do k=1,3
21467       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21468       enddo
21469       do k=1,3
21470       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21471            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21472            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21473       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21474            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21475            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21476       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21477       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21478       enddo
21479 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21480        IF ( j.gt.i+1 .and.&
21481         num_conti.le.maxcont) THEN
21482 !C
21483 !C Calculate the contact function. The ith column of the array JCONT will
21484 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21485 !C greater than I). The arrays FACONT and GACONT will contain the values of
21486 !C the contact function and its derivative.
21487       r0ij=2.20D0*sigma_nucl(itypi,itypj)
21488 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21489       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21490 !c        write (2,*) "fcont",fcont
21491       if (fcont.gt.0.0D0) then
21492         num_conti=num_conti+1
21493         num_conti2=num_conti2+1
21494
21495         if (num_conti.gt.maxconts) then
21496           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21497                     ' will skip next contacts for this conf.',maxconts
21498         else
21499           jcont_hb(num_conti,i)=j
21500 !c            write (iout,*) "num_conti",num_conti,
21501 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21502 !C Calculate contact energies
21503           cosa4=4.0D0*cosa
21504           wij=cosa-3.0D0*cosb*cosg
21505           cosbg1=cosb+cosg
21506           cosbg2=cosb-cosg
21507           fac3=dsqrt(-ael6i)*r3ij
21508 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21509           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21510           if (ees0tmp.gt.0) then
21511             ees0pij=dsqrt(ees0tmp)
21512           else
21513             ees0pij=0
21514           endif
21515           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21516           if (ees0tmp.gt.0) then
21517             ees0mij=dsqrt(ees0tmp)
21518           else
21519             ees0mij=0
21520           endif
21521           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21522           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21523 !c            write (iout,*) "i",i," j",j,
21524 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21525           ees0pij1=fac3/ees0pij
21526           ees0mij1=fac3/ees0mij
21527           fac3p=-3.0D0*fac3*rrij
21528           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21529           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21530           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21531           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21532           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21533           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21534           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21535           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21536           ecosap=ecosa1+ecosa2
21537           ecosbp=ecosb1+ecosb2
21538           ecosgp=ecosg1+ecosg2
21539           ecosam=ecosa1-ecosa2
21540           ecosbm=ecosb1-ecosb2
21541           ecosgm=ecosg1-ecosg2
21542 !C End diagnostics
21543           facont_hb(num_conti,i)=fcont
21544           fprimcont=fprimcont/rij
21545           do k=1,3
21546             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21547             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21548           enddo
21549           gggp(1)=gggp(1)+ees0pijp*xj
21550           gggp(2)=gggp(2)+ees0pijp*yj
21551           gggp(3)=gggp(3)+ees0pijp*zj
21552           gggm(1)=gggm(1)+ees0mijp*xj
21553           gggm(2)=gggm(2)+ees0mijp*yj
21554           gggm(3)=gggm(3)+ees0mijp*zj
21555 !C Derivatives due to the contact function
21556           gacont_hbr(1,num_conti,i)=fprimcont*xj
21557           gacont_hbr(2,num_conti,i)=fprimcont*yj
21558           gacont_hbr(3,num_conti,i)=fprimcont*zj
21559           do k=1,3
21560 !c
21561 !c Gradient of the correlation terms
21562 !c
21563             gacontp_hb1(k,num_conti,i)= &
21564            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21565           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21566             gacontp_hb2(k,num_conti,i)= &
21567            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21568           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21569             gacontp_hb3(k,num_conti,i)=gggp(k)
21570             gacontm_hb1(k,num_conti,i)= &
21571            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21572           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21573             gacontm_hb2(k,num_conti,i)= &
21574            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21575           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21576             gacontm_hb3(k,num_conti,i)=gggm(k)
21577           enddo
21578         endif
21579       endif
21580       ENDIF
21581       return
21582       end subroutine eelsbij
21583 !------------------------------------------------------------------
21584       subroutine sc_grad_nucl
21585       use comm_locel
21586       use calc_data_nucl
21587       real(kind=8),dimension(3) :: dcosom1,dcosom2
21588       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21589       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21590       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21591       do k=1,3
21592       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21593       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21594       enddo
21595       do k=1,3
21596       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21597       enddo
21598       do k=1,3
21599       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21600              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21601              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21602       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21603              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21604              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21605       enddo
21606 !C
21607 !C Calculate the components of the gradient in DC and X
21608 !C
21609       do l=1,3
21610       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21611       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21612       enddo
21613       return
21614       end subroutine sc_grad_nucl
21615 !-----------------------------------------------------------------------
21616       subroutine esb(esbloc)
21617 !C Calculate the local energy of a side chain and its derivatives in the
21618 !C corresponding virtual-bond valence angles THETA and the spherical angles
21619 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21620 !C added by Urszula Kozlowska. 07/11/2007
21621 !C
21622       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21623       real(kind=8),dimension(9):: x
21624      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21625       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21626       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21627       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21628        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21629        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21630        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21631        integer::it,nlobit,i,j,k
21632 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21633       delta=0.02d0*pi
21634       esbloc=0.0D0
21635       do i=loc_start_nucl,loc_end_nucl
21636       if (itype(i,2).eq.ntyp1_molec(2)) cycle
21637       costtab(i+1) =dcos(theta(i+1))
21638       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21639       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21640       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21641       cosfac2=0.5d0/(1.0d0+costtab(i+1))
21642       cosfac=dsqrt(cosfac2)
21643       sinfac2=0.5d0/(1.0d0-costtab(i+1))
21644       sinfac=dsqrt(sinfac2)
21645       it=itype(i,2)
21646       if (it.eq.10) goto 1
21647
21648 !c
21649 !C  Compute the axes of tghe local cartesian coordinates system; store in
21650 !c   x_prime, y_prime and z_prime
21651 !c
21652       do j=1,3
21653         x_prime(j) = 0.00
21654         y_prime(j) = 0.00
21655         z_prime(j) = 0.00
21656       enddo
21657 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21658 !C     &   dc_norm(3,i+nres)
21659       do j = 1,3
21660         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21661         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21662       enddo
21663       do j = 1,3
21664         z_prime(j) = -uz(j,i-1)
21665 !           z_prime(j)=0.0
21666       enddo
21667
21668       xx=0.0d0
21669       yy=0.0d0
21670       zz=0.0d0
21671       do j = 1,3
21672         xx = xx + x_prime(j)*dc_norm(j,i+nres)
21673         yy = yy + y_prime(j)*dc_norm(j,i+nres)
21674         zz = zz + z_prime(j)*dc_norm(j,i+nres)
21675       enddo
21676
21677       xxtab(i)=xx
21678       yytab(i)=yy
21679       zztab(i)=zz
21680        it=itype(i,2)
21681       do j = 1,9
21682         x(j) = sc_parmin_nucl(j,it)
21683       enddo
21684 #ifdef CHECK_COORD
21685 !Cc diagnostics - remove later
21686       xx1 = dcos(alph(2))
21687       yy1 = dsin(alph(2))*dcos(omeg(2))
21688       zz1 = -dsin(alph(2))*dsin(omeg(2))
21689       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21690        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21691        xx1,yy1,zz1
21692 !C,"  --- ", xx_w,yy_w,zz_w
21693 !c end diagnostics
21694 #endif
21695       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21696       esbloc = esbloc + sumene
21697       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21698 !        print *,"enecomp",sumene,sumene2
21699 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21700 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21701 #ifdef DEBUG
21702       write (2,*) "x",(x(k),k=1,9)
21703 !C
21704 !C This section to check the numerical derivatives of the energy of ith side
21705 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21706 !C #define DEBUG in the code to turn it on.
21707 !C
21708       write (2,*) "sumene               =",sumene
21709       aincr=1.0d-7
21710       xxsave=xx
21711       xx=xx+aincr
21712       write (2,*) xx,yy,zz
21713       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21714       de_dxx_num=(sumenep-sumene)/aincr
21715       xx=xxsave
21716       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21717       yysave=yy
21718       yy=yy+aincr
21719       write (2,*) xx,yy,zz
21720       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21721       de_dyy_num=(sumenep-sumene)/aincr
21722       yy=yysave
21723       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21724       zzsave=zz
21725       zz=zz+aincr
21726       write (2,*) xx,yy,zz
21727       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21728       de_dzz_num=(sumenep-sumene)/aincr
21729       zz=zzsave
21730       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21731       costsave=cost2tab(i+1)
21732       sintsave=sint2tab(i+1)
21733       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21734       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21735       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21736       de_dt_num=(sumenep-sumene)/aincr
21737       write (2,*) " t+ sumene from enesc=",sumenep,sumene
21738       cost2tab(i+1)=costsave
21739       sint2tab(i+1)=sintsave
21740 !C End of diagnostics section.
21741 #endif
21742 !C
21743 !C Compute the gradient of esc
21744 !C
21745       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21746       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21747       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21748       de_dtt=0.0d0
21749 #ifdef DEBUG
21750       write (2,*) "x",(x(k),k=1,9)
21751       write (2,*) "xx",xx," yy",yy," zz",zz
21752       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21753         " de_zz   ",de_zz," de_tt   ",de_tt
21754       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21755         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21756 #endif
21757 !C
21758        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21759        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21760        cosfac2xx=cosfac2*xx
21761        sinfac2yy=sinfac2*yy
21762        do k = 1,3
21763        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21764          vbld_inv(i+1)
21765        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21766          vbld_inv(i)
21767        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21768        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21769 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21770 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21771 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21772 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21773        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21774        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21775        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21776        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21777        dZZ_Ci1(k)=0.0d0
21778        dZZ_Ci(k)=0.0d0
21779        do j=1,3
21780          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21781          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21782        enddo
21783
21784        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21785        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21786        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21787 !c
21788        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21789        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21790        enddo
21791
21792        do k=1,3
21793        dXX_Ctab(k,i)=dXX_Ci(k)
21794        dXX_C1tab(k,i)=dXX_Ci1(k)
21795        dYY_Ctab(k,i)=dYY_Ci(k)
21796        dYY_C1tab(k,i)=dYY_Ci1(k)
21797        dZZ_Ctab(k,i)=dZZ_Ci(k)
21798        dZZ_C1tab(k,i)=dZZ_Ci1(k)
21799        dXX_XYZtab(k,i)=dXX_XYZ(k)
21800        dYY_XYZtab(k,i)=dYY_XYZ(k)
21801        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21802        enddo
21803        do k = 1,3
21804 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21805 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21806 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21807 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21808 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21809 !c     &    dt_dci(k)
21810 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21811 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21812        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21813        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21814        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21815        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21816        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21817        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21818 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21819        enddo
21820 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21821 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21822
21823 !C to check gradient call subroutine check_grad
21824
21825     1 continue
21826       enddo
21827       return
21828       end subroutine esb
21829 !=-------------------------------------------------------
21830       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21831 !      implicit none
21832       real(kind=8),dimension(9):: x(9)
21833        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21834       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21835       integer i
21836 !c      write (2,*) "enesc"
21837 !c      write (2,*) "x",(x(i),i=1,9)
21838 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21839       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21840       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21841       + x(9)*yy*zz
21842       enesc_nucl=sumene
21843       return
21844       end function enesc_nucl
21845 !-----------------------------------------------------------------------------
21846       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21847 #ifdef MPI
21848       include 'mpif.h'
21849       integer,parameter :: max_cont=2000
21850       integer,parameter:: max_dim=2*(8*3+6)
21851       integer, parameter :: msglen1=max_cont*max_dim
21852       integer,parameter :: msglen2=2*msglen1
21853       integer source,CorrelType,CorrelID,Error
21854       real(kind=8) :: buffer(max_cont,max_dim)
21855       integer status(MPI_STATUS_SIZE)
21856       integer :: ierror,nbytes
21857 #endif
21858       real(kind=8),dimension(3):: gx(3),gx1(3)
21859       real(kind=8) :: time00
21860       logical lprn,ldone
21861       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21862       real(kind=8) ecorr,ecorr3
21863       integer :: n_corr,n_corr1,mm,msglen
21864 !C Set lprn=.true. for debugging
21865       lprn=.false.
21866       n_corr=0
21867       n_corr1=0
21868 #ifdef MPI
21869       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21870
21871       if (nfgtasks.le.1) goto 30
21872       if (lprn) then
21873       write (iout,'(a)') 'Contact function values:'
21874       do i=nnt,nct-1
21875         write (iout,'(2i3,50(1x,i2,f5.2))')  &
21876        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21877        j=1,num_cont_hb(i))
21878       enddo
21879       endif
21880 !C Caution! Following code assumes that electrostatic interactions concerning
21881 !C a given atom are split among at most two processors!
21882       CorrelType=477
21883       CorrelID=fg_rank+1
21884       ldone=.false.
21885       do i=1,max_cont
21886       do j=1,max_dim
21887         buffer(i,j)=0.0D0
21888       enddo
21889       enddo
21890       mm=mod(fg_rank,2)
21891 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21892       if (mm) 20,20,10
21893    10 continue
21894 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21895       if (fg_rank.gt.0) then
21896 !C Send correlation contributions to the preceding processor
21897       msglen=msglen1
21898       nn=num_cont_hb(iatel_s_nucl)
21899       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21900 !c        write (*,*) 'The BUFFER array:'
21901 !c        do i=1,nn
21902 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21903 !c        enddo
21904       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21905         msglen=msglen2
21906         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21907 !C Clear the contacts of the atom passed to the neighboring processor
21908       nn=num_cont_hb(iatel_s_nucl+1)
21909 !c        do i=1,nn
21910 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21911 !c        enddo
21912           num_cont_hb(iatel_s_nucl)=0
21913       endif
21914 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21915 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21916 !cd   & ' msglen=',msglen
21917 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21918 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21919 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21920       time00=MPI_Wtime()
21921       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21922        CorrelType,FG_COMM,IERROR)
21923       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21924 !cd      write (iout,*) 'Processor ',fg_rank,
21925 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21926 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21927 !c        write (*,*) 'Processor ',fg_rank,
21928 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21929 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21930 !c        msglen=msglen1
21931       endif ! (fg_rank.gt.0)
21932       if (ldone) goto 30
21933       ldone=.true.
21934    20 continue
21935 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21936       if (fg_rank.lt.nfgtasks-1) then
21937 !C Receive correlation contributions from the next processor
21938       msglen=msglen1
21939       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21940 !cd      write (iout,*) 'Processor',fg_rank,
21941 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21942 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21943 !c        write (*,*) 'Processor',fg_rank,
21944 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21945 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21946       time00=MPI_Wtime()
21947       nbytes=-1
21948       do while (nbytes.le.0)
21949         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21950         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21951       enddo
21952 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21953       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21954        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21955       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21956 !c        write (*,*) 'Processor',fg_rank,
21957 !c     &' has received correlation contribution from processor',fg_rank+1,
21958 !c     & ' msglen=',msglen,' nbytes=',nbytes
21959 !c        write (*,*) 'The received BUFFER array:'
21960 !c        do i=1,max_cont
21961 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21962 !c        enddo
21963       if (msglen.eq.msglen1) then
21964         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21965       else if (msglen.eq.msglen2)  then
21966         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21967         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21968       else
21969         write (iout,*) &
21970       'ERROR!!!! message length changed while processing correlations.'
21971         write (*,*) &
21972       'ERROR!!!! message length changed while processing correlations.'
21973         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21974       endif ! msglen.eq.msglen1
21975       endif ! fg_rank.lt.nfgtasks-1
21976       if (ldone) goto 30
21977       ldone=.true.
21978       goto 10
21979    30 continue
21980 #endif
21981       if (lprn) then
21982       write (iout,'(a)') 'Contact function values:'
21983       do i=nnt_molec(2),nct_molec(2)-1
21984         write (iout,'(2i3,50(1x,i2,f5.2))') &
21985        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21986        j=1,num_cont_hb(i))
21987       enddo
21988       endif
21989       ecorr=0.0D0
21990       ecorr3=0.0d0
21991 !C Remove the loop below after debugging !!!
21992 !      do i=nnt_molec(2),nct_molec(2)
21993 !        do j=1,3
21994 !          gradcorr_nucl(j,i)=0.0D0
21995 !          gradxorr_nucl(j,i)=0.0D0
21996 !          gradcorr3_nucl(j,i)=0.0D0
21997 !          gradxorr3_nucl(j,i)=0.0D0
21998 !        enddo
21999 !      enddo
22000 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22001 !C Calculate the local-electrostatic correlation terms
22002       do i=iatsc_s_nucl,iatsc_e_nucl
22003       i1=i+1
22004       num_conti=num_cont_hb(i)
22005       num_conti1=num_cont_hb(i+1)
22006 !        print *,i,num_conti,num_conti1
22007       do jj=1,num_conti
22008         j=jcont_hb(jj,i)
22009         do kk=1,num_conti1
22010           j1=jcont_hb(kk,i1)
22011 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22012 !c     &         ' jj=',jj,' kk=',kk
22013           if (j1.eq.j+1 .or. j1.eq.j-1) then
22014 !C
22015 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22016 !C The system gains extra energy.
22017 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22018 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22019 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22020 !C
22021             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22022             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22023              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22024             n_corr=n_corr+1
22025           else if (j1.eq.j) then
22026 !C
22027 !C Contacts I-J and I-(J+1) occur simultaneously.
22028 !C The system loses extra energy.
22029 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22030 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22031 !C Need to implement full formulas 32 from Liwo et al., 1998.
22032 !C
22033 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22034 !c     &         ' jj=',jj,' kk=',kk
22035             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22036           endif
22037         enddo ! kk
22038         do kk=1,num_conti
22039           j1=jcont_hb(kk,i)
22040 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22041 !c     &         ' jj=',jj,' kk=',kk
22042           if (j1.eq.j+1) then
22043 !C Contacts I-J and (I+1)-J occur simultaneously.
22044 !C The system loses extra energy.
22045             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22046           endif ! j1==j+1
22047         enddo ! kk
22048       enddo ! jj
22049       enddo ! i
22050       return
22051       end subroutine multibody_hb_nucl
22052 !-----------------------------------------------------------
22053       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22054 !      implicit real*8 (a-h,o-z)
22055 !      include 'DIMENSIONS'
22056 !      include 'COMMON.IOUNITS'
22057 !      include 'COMMON.DERIV'
22058 !      include 'COMMON.INTERACT'
22059 !      include 'COMMON.CONTACTS'
22060       real(kind=8),dimension(3) :: gx,gx1
22061       logical :: lprn
22062 !el local variables
22063       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22064       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22065                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22066                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22067                rlocshield
22068
22069       lprn=.false.
22070       eij=facont_hb(jj,i)
22071       ekl=facont_hb(kk,k)
22072       ees0pij=ees0p(jj,i)
22073       ees0pkl=ees0p(kk,k)
22074       ees0mij=ees0m(jj,i)
22075       ees0mkl=ees0m(kk,k)
22076       ekont=eij*ekl
22077       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22078 !      print *,"ehbcorr_nucl",ekont,ees
22079 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22080 !C Following 4 lines for diagnostics.
22081 !cd    ees0pkl=0.0D0
22082 !cd    ees0pij=1.0D0
22083 !cd    ees0mkl=0.0D0
22084 !cd    ees0mij=1.0D0
22085 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22086 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22087 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22088 !C Calculate the multi-body contribution to energy.
22089 !      ecorr_nucl=ecorr_nucl+ekont*ees
22090 !C Calculate multi-body contributions to the gradient.
22091       coeffpees0pij=coeffp*ees0pij
22092       coeffmees0mij=coeffm*ees0mij
22093       coeffpees0pkl=coeffp*ees0pkl
22094       coeffmees0mkl=coeffm*ees0mkl
22095       do ll=1,3
22096       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22097        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22098        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22099       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22100       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22101       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22102       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22103       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22104       coeffmees0mij*gacontm_hb1(ll,kk,k))
22105       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22106       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22107       coeffmees0mij*gacontm_hb2(ll,kk,k))
22108       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22109         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22110         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22111       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22112       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22113       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22114         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22115         coeffmees0mij*gacontm_hb3(ll,kk,k))
22116       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22117       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22118       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22119       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22120       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22121       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22122       enddo
22123       ehbcorr_nucl=ekont*ees
22124       return
22125       end function ehbcorr_nucl
22126 !-------------------------------------------------------------------------
22127
22128      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22129 !      implicit real*8 (a-h,o-z)
22130 !      include 'DIMENSIONS'
22131 !      include 'COMMON.IOUNITS'
22132 !      include 'COMMON.DERIV'
22133 !      include 'COMMON.INTERACT'
22134 !      include 'COMMON.CONTACTS'
22135       real(kind=8),dimension(3) :: gx,gx1
22136       logical :: lprn
22137 !el local variables
22138       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22139       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22140                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22141                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22142                rlocshield
22143
22144       lprn=.false.
22145       eij=facont_hb(jj,i)
22146       ekl=facont_hb(kk,k)
22147       ees0pij=ees0p(jj,i)
22148       ees0pkl=ees0p(kk,k)
22149       ees0mij=ees0m(jj,i)
22150       ees0mkl=ees0m(kk,k)
22151       ekont=eij*ekl
22152       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22153 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22154 !C Following 4 lines for diagnostics.
22155 !cd    ees0pkl=0.0D0
22156 !cd    ees0pij=1.0D0
22157 !cd    ees0mkl=0.0D0
22158 !cd    ees0mij=1.0D0
22159 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22160 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22161 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22162 !C Calculate the multi-body contribution to energy.
22163 !      ecorr=ecorr+ekont*ees
22164 !C Calculate multi-body contributions to the gradient.
22165       coeffpees0pij=coeffp*ees0pij
22166       coeffmees0mij=coeffm*ees0mij
22167       coeffpees0pkl=coeffp*ees0pkl
22168       coeffmees0mkl=coeffm*ees0mkl
22169       do ll=1,3
22170       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22171        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22172        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22173       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22174       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22175       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22176       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22177       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22178       coeffmees0mij*gacontm_hb1(ll,kk,k))
22179       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22180       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22181       coeffmees0mij*gacontm_hb2(ll,kk,k))
22182       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22183         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22184         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22185       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22186       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22187       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22188         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22189         coeffmees0mij*gacontm_hb3(ll,kk,k))
22190       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22191       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22192       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22193       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22194       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22195       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22196       enddo
22197       ehbcorr3_nucl=ekont*ees
22198       return
22199       end function ehbcorr3_nucl
22200 #ifdef MPI
22201       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22202       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22203       real(kind=8):: buffer(dimen1,dimen2)
22204       num_kont=num_cont_hb(atom)
22205       do i=1,num_kont
22206       do k=1,8
22207         do j=1,3
22208           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22209         enddo ! j
22210       enddo ! k
22211       buffer(i,indx+25)=facont_hb(i,atom)
22212       buffer(i,indx+26)=ees0p(i,atom)
22213       buffer(i,indx+27)=ees0m(i,atom)
22214       buffer(i,indx+28)=d_cont(i,atom)
22215       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22216       enddo ! i
22217       buffer(1,indx+30)=dfloat(num_kont)
22218       return
22219       end subroutine pack_buffer
22220 !c------------------------------------------------------------------------------
22221       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22222       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22223       real(kind=8):: buffer(dimen1,dimen2)
22224 !      double precision zapas
22225 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22226 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22227 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22228 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22229       num_kont=buffer(1,indx+30)
22230       num_kont_old=num_cont_hb(atom)
22231       num_cont_hb(atom)=num_kont+num_kont_old
22232       do i=1,num_kont
22233       ii=i+num_kont_old
22234       do k=1,8
22235         do j=1,3
22236           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22237         enddo ! j
22238       enddo ! k
22239       facont_hb(ii,atom)=buffer(i,indx+25)
22240       ees0p(ii,atom)=buffer(i,indx+26)
22241       ees0m(ii,atom)=buffer(i,indx+27)
22242       d_cont(i,atom)=buffer(i,indx+28)
22243       jcont_hb(ii,atom)=buffer(i,indx+29)
22244       enddo ! i
22245       return
22246       end subroutine unpack_buffer
22247 !c------------------------------------------------------------------------------
22248 #endif
22249       subroutine ecatcat(ecationcation)
22250       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22251       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22252       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22253       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22254       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22255       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22256       gg,r
22257
22258       ecationcation=0.0d0
22259       if (nres_molec(5).eq.0) return
22260       rcat0=3.472
22261       epscalc=0.05
22262       r06 = rcat0**6
22263       r012 = r06**2
22264 !        k0 = 332.0*(2.0*2.0)/80.0
22265       itmp=0
22266
22267       do i=1,4
22268       itmp=itmp+nres_molec(i)
22269       enddo
22270 !        write(iout,*) "itmp",itmp
22271       do i=itmp+1,itmp+nres_molec(5)-1
22272
22273       xi=c(1,i)
22274       yi=c(2,i)
22275       zi=c(3,i)
22276 !        write (iout,*) i,"TUTUT",c(1,i)
22277         itypi=itype(i,5)
22278       call to_box(xi,yi,zi)
22279       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22280         do j=i+1,itmp+nres_molec(5)
22281         itypj=itype(j,5)
22282 !          print *,i,j,itypi,itypj
22283         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22284 !           print *,i,j,'catcat'
22285          xj=c(1,j)
22286          yj=c(2,j)
22287          zj=c(3,j)
22288       call to_box(xj,yj,zj)
22289 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22290 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22291 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22292 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22293 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22294       xj=boxshift(xj-xi,boxxsize)
22295       yj=boxshift(yj-yi,boxysize)
22296       zj=boxshift(zj-zi,boxzsize)
22297        rcal =xj**2+yj**2+zj**2
22298       ract=sqrt(rcal)
22299 !        rcat0=3.472
22300 !        epscalc=0.05
22301 !        r06 = rcat0**6
22302 !        r012 = r06**2
22303 !        k0 = 332*(2*2)/80
22304       Evan1cat=epscalc*(r012/(rcal**6))
22305       Evan2cat=epscalc*2*(r06/(rcal**3))
22306       Eeleccat=k0/ract
22307       r7 = rcal**7
22308       r4 = rcal**4
22309       r(1)=xj
22310       r(2)=yj
22311       r(3)=zj
22312       do k=1,3
22313         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22314         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22315         dEeleccat(k)=-k0*r(k)/ract**3
22316       enddo
22317       do k=1,3
22318         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22319         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22320         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22321       enddo
22322       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22323        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22324 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22325       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22326        enddo
22327        enddo
22328        return
22329        end subroutine ecatcat
22330 !---------------------------------------------------------------------------
22331 ! new for K+
22332       subroutine ecats_prot_amber(evdw)
22333 !      subroutine ecat_prot2(ecation_prot)
22334       use calc_data
22335       use comm_momo
22336
22337       logical :: lprn
22338 !el local variables
22339       integer :: iint,itypi1,subchap,isel,itmp
22340       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22341       real(kind=8) :: evdw,aa,bb
22342       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22343                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22344                 sslipi,sslipj,faclip,alpha_sco
22345       integer :: ii
22346       real(kind=8) :: fracinbuf
22347       real (kind=8) :: escpho
22348       real (kind=8),dimension(4):: ener
22349       real(kind=8) :: b1,b2,egb
22350       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22351        Lambf,&
22352        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22353        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22354        federmaus,&
22355        d1i,d1j
22356 !       real(kind=8),dimension(3,2)::erhead_tail
22357 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22358       real(kind=8) ::  facd4, adler, Fgb, facd3
22359       integer troll,jj,istate
22360       real (kind=8) :: dcosom1(3),dcosom2(3)
22361       real(kind=8) ::locbox(3)
22362       locbox(1)=boxxsize
22363           locbox(2)=boxysize
22364       locbox(3)=boxzsize
22365
22366       evdw=0.0D0
22367       if (nres_molec(5).eq.0) return
22368       eps_out=80.0d0
22369 !      sss_ele_cut=1.0d0
22370
22371       itmp=0
22372       do i=1,4
22373       itmp=itmp+nres_molec(i)
22374       enddo
22375 !        go to 17
22376 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22377       do i=ibond_start,ibond_end
22378
22379 !        print *,"I am in EVDW",i
22380       itypi=iabs(itype(i,1))
22381
22382 !        if (i.ne.47) cycle
22383       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22384       itypi1=iabs(itype(i+1,1))
22385       xi=c(1,nres+i)
22386       yi=c(2,nres+i)
22387       zi=c(3,nres+i)
22388       call to_box(xi,yi,zi)
22389       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22390       dxi=dc_norm(1,nres+i)
22391       dyi=dc_norm(2,nres+i)
22392       dzi=dc_norm(3,nres+i)
22393       dsci_inv=vbld_inv(i+nres)
22394        do j=itmp+1,itmp+nres_molec(5)
22395
22396 ! Calculate SC interaction energy.
22397           itypj=iabs(itype(j,5))
22398           if ((itypj.eq.ntyp1)) cycle
22399            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22400
22401           dscj_inv=0.0
22402          xj=c(1,j)
22403          yj=c(2,j)
22404          zj=c(3,j)
22405
22406       call to_box(xj,yj,zj)
22407 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
22408
22409 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22410 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22411 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22412 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22413 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22414       xj=boxshift(xj-xi,boxxsize)
22415       yj=boxshift(yj-yi,boxysize)
22416       zj=boxshift(zj-zi,boxzsize)
22417 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
22418
22419 !          dxj = dc_norm( 1, nres+j )
22420 !          dyj = dc_norm( 2, nres+j )
22421 !          dzj = dc_norm( 3, nres+j )
22422
22423         itypi = itype(i,1)
22424         itypj = itype(j,5)
22425 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22426 ! sampling performed with amber package
22427 !          alf1   = 0.0d0
22428 !          alf2   = 0.0d0
22429 !          alf12  = 0.0d0
22430 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22431         chi1 = chi1cat(itypi,itypj)
22432         chis1 = chis1cat(itypi,itypj)
22433         chip1 = chipp1cat(itypi,itypj)
22434 !          chi1=0.0d0
22435 !          chis1=0.0d0
22436 !          chip1=0.0d0
22437         chi2=0.0
22438         chip2=0.0
22439         chis2=0.0
22440 !          chis2 = chis(itypj,itypi)
22441         chis12 = chis1 * chis2
22442         sig1 = sigmap1cat(itypi,itypj)
22443 !          sig2 = sigmap2(itypi,itypj)
22444 ! alpha factors from Fcav/Gcav
22445         b1cav = alphasurcat(1,itypi,itypj)
22446         b2cav = alphasurcat(2,itypi,itypj)
22447         b3cav = alphasurcat(3,itypi,itypj)
22448         b4cav = alphasurcat(4,itypi,itypj)
22449
22450 !        b1cav=0.0d0
22451 !        b2cav=0.0d0
22452 !        b3cav=0.0d0
22453 !        b4cav=0.0d0
22454
22455 ! used to determine whether we want to do quadrupole calculations
22456        eps_in = epsintabcat(itypi,itypj)
22457        if (eps_in.eq.0.0) eps_in=1.0
22458
22459        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22460 !       Rtail = 0.0d0
22461
22462        DO k = 1, 3
22463       ctail(k,1)=c(k,i+nres)
22464       ctail(k,2)=c(k,j)
22465        END DO
22466       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
22467       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
22468 !c! tail distances will be themselves usefull elswhere
22469 !c1 (in Gcav, for example)
22470        do k=1,3
22471        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
22472        enddo
22473        Rtail = dsqrt( &
22474         (Rtail_distance(1)*Rtail_distance(1)) &
22475       + (Rtail_distance(2)*Rtail_distance(2)) &
22476       + (Rtail_distance(3)*Rtail_distance(3)))
22477 ! tail location and distance calculations
22478 ! dhead1
22479        d1 = dheadcat(1, 1, itypi, itypj)
22480 !       d2 = dhead(2, 1, itypi, itypj)
22481        DO k = 1,3
22482 ! location of polar head is computed by taking hydrophobic centre
22483 ! and moving by a d1 * dc_norm vector
22484 ! see unres publications for very informative images
22485       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22486       chead(k,2) = c(k, j)
22487       enddo
22488       call to_box(chead(1,1),chead(2,1),chead(3,1))
22489       call to_box(chead(1,2),chead(2,2),chead(3,2))
22490 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
22491 ! distance
22492 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22493 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22494       do k=1,3
22495       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
22496        END DO
22497 ! pitagoras (root of sum of squares)
22498        Rhead = dsqrt( &
22499         (Rhead_distance(1)*Rhead_distance(1)) &
22500       + (Rhead_distance(2)*Rhead_distance(2)) &
22501       + (Rhead_distance(3)*Rhead_distance(3)))
22502 !-------------------------------------------------------------------
22503 ! zero everything that should be zero'ed
22504        evdwij = 0.0d0
22505        ECL = 0.0d0
22506        Elj = 0.0d0
22507        Equad = 0.0d0
22508        Epol = 0.0d0
22509        Fcav=0.0d0
22510        eheadtail = 0.0d0
22511        dGCLdOM1 = 0.0d0
22512        dGCLdOM2 = 0.0d0
22513        dGCLdOM12 = 0.0d0
22514        dPOLdOM1 = 0.0d0
22515        dPOLdOM2 = 0.0d0
22516         Fcav = 0.0d0
22517         Fisocav=0.0d0
22518         dFdR = 0.0d0
22519         dCAVdOM1  = 0.0d0
22520         dCAVdOM2  = 0.0d0
22521         dCAVdOM12 = 0.0d0
22522         dscj_inv = vbld_inv(j+nres)
22523 !          print *,i,j,dscj_inv,dsci_inv
22524 ! rij holds 1/(distance of Calpha atoms)
22525         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22526         rij  = dsqrt(rrij)
22527         CALL sc_angular
22528 ! this should be in elgrad_init but om's are calculated by sc_angular
22529 ! which in turn is used by older potentials
22530 ! om = omega, sqom = om^2
22531         sqom1  = om1 * om1
22532         sqom2  = om2 * om2
22533         sqom12 = om12 * om12
22534
22535 ! now we calculate EGB - Gey-Berne
22536 ! It will be summed up in evdwij and saved in evdw
22537         sigsq     = 1.0D0  / sigsq
22538         sig       = sig0ij * dsqrt(sigsq)
22539 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22540         rij_shift = Rtail - sig + sig0ij
22541         IF (rij_shift.le.0.0D0) THEN
22542          evdw = 1.0D20
22543       if (evdw.gt.1.0d6) then
22544       write (*,'(2(1x,a3,i3),7f7.2)') &
22545       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22546       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
22547       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
22548      write(*,*) "ANISO?!",chi1
22549 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22550 !      Equad,evdwij+Fcav+eheadtail,evdw
22551       endif
22552
22553          RETURN
22554         END IF
22555         sigder = -sig * sigsq
22556         rij_shift = 1.0D0 / rij_shift
22557         fac       = rij_shift**expon
22558         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22559 !          print *,"ADAM",aa_aq(itypi,itypj)
22560
22561 !          c1        = 0.0d0
22562         c2        = fac  * bb_aq_cat(itypi,itypj)
22563 !          c2        = 0.0d0
22564         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22565         eps2der   = eps3rt * evdwij
22566         eps3der   = eps2rt * evdwij
22567 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22568         evdwij    = eps2rt * eps3rt * evdwij
22569 !#ifdef TSCSC
22570 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22571 !           evdw_p = evdw_p + evdwij
22572 !          ELSE
22573 !           evdw_m = evdw_m + evdwij
22574 !          END IF
22575 !#else
22576         evdw = evdw  &
22577             + evdwij
22578 !#endif
22579         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22580         fac    = -expon * (c1 + evdwij) * rij_shift
22581         sigder = fac * sigder
22582 ! Calculate distance derivative
22583         gg(1) =  fac
22584         gg(2) =  fac
22585         gg(3) =  fac
22586 !       print *,"GG(1),distance grad",gg(1)
22587         fac = chis1 * sqom1 + chis2 * sqom2 &
22588         - 2.0d0 * chis12 * om1 * om2 * om12
22589         pom = 1.0d0 - chis1 * chis2 * sqom12
22590         Lambf = (1.0d0 - (fac / pom))
22591         Lambf = dsqrt(Lambf)
22592         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22593         Chif = Rtail * sparrow
22594         ChiLambf = Chif * Lambf
22595         eagle = dsqrt(ChiLambf)
22596         bat = ChiLambf ** 11.0d0
22597         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22598         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22599         botsq = bot * bot
22600         Fcav = top / bot
22601
22602        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22603        dbot = 12.0d0 * b4cav * bat * Lambf
22604        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22605
22606         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22607         dbot = 12.0d0 * b4cav * bat * Chif
22608         eagle = Lambf * pom
22609         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22610         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22611         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22612             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22613
22614         dFdL = ((dtop * bot - top * dbot) / botsq)
22615         dCAVdOM1  = dFdL * ( dFdOM1 )
22616         dCAVdOM2  = dFdL * ( dFdOM2 )
22617         dCAVdOM12 = dFdL * ( dFdOM12 )
22618
22619        DO k= 1, 3
22620       ertail(k) = Rtail_distance(k)/Rtail
22621        END DO
22622        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22623        erdxj = scalar( ertail(1), dC_norm(1,j) )
22624        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
22625        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j)
22626        DO k = 1, 3
22627       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22628       gradpepcatx(k,i) = gradpepcatx(k,i) &
22629               - (( dFdR + gg(k) ) * pom)
22630       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j))
22631 !        gvdwx(k,j) = gvdwx(k,j)   &
22632 !                  + (( dFdR + gg(k) ) * pom)
22633       gradpepcat(k,i) = gradpepcat(k,i)  &
22634               - (( dFdR + gg(k) ) * ertail(k))
22635       gradpepcat(k,j) = gradpepcat(k,j) &
22636               + (( dFdR + gg(k) ) * ertail(k))
22637       gg(k) = 0.0d0
22638        ENDDO
22639 !c! Compute head-head and head-tail energies for each state
22640 !!        if (.false.) then ! turn off electrostatic
22641         if (itype(j,5).gt.0) then ! the normal cation case
22642         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
22643 !        print *,i,itype(i,1),isel
22644         IF (isel.eq.0) THEN
22645 !c! No charges - do nothing
22646          eheadtail = 0.0d0
22647
22648         ELSE IF (isel.eq.1) THEN
22649 !c! Nonpolar-charge interactions
22650         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22651           Qi=Qi*2
22652           Qij=Qij*2
22653          endif
22654
22655          CALL enq_cat(epol)
22656          eheadtail = epol
22657 !           eheadtail = 0.0d0
22658
22659         ELSE IF (isel.eq.3) THEN
22660 !c! Dipole-charge interactions
22661         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22662           Qi=Qi*2
22663           Qij=Qij*2
22664          endif
22665 !         write(iout,*) "KURWA0",d1
22666
22667          CALL edq_cat(ecl, elj, epol)
22668         eheadtail = ECL + elj + epol
22669 !           eheadtail = 0.0d0
22670
22671         ELSE IF ((isel.eq.2)) THEN
22672
22673 !c! Same charge-charge interaction ( +/+ or -/- )
22674         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22675           Qi=Qi*2
22676           Qij=Qij*2
22677          endif
22678
22679          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
22680          eheadtail = ECL + Egb + Epol + Fisocav + Elj
22681 !           eheadtail = 0.0d0
22682
22683 !          ELSE IF ((isel.eq.2.and.  &
22684 !               iabs(Qi).eq.1).and. &
22685 !               nstate(itypi,itypj).ne.1) THEN
22686 !c! Different charge-charge interaction ( +/- or -/+ )
22687 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22688 !            Qi=Qi*2
22689 !            Qij=Qij*2
22690 !           endif
22691 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22692 !            Qj=Qj*2
22693 !            Qij=Qij*2
22694 !           endif
22695 !
22696 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
22697        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
22698        else
22699        write(iout,*) "not yet implemented",j,itype(j,5)
22700        endif
22701 !!       endif ! turn off electrostatic
22702       evdw = evdw  + Fcav + eheadtail
22703 !      if (evdw.gt.1.0d6) then
22704 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22705 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22706 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22707 !      Equad,evdwij+Fcav+eheadtail,evdw
22708 !      endif
22709
22710        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22711       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22712       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22713       Equad,evdwij+Fcav+eheadtail,evdw
22714 !       evdw = evdw  + Fcav  + eheadtail
22715 !       print *,"before sc_grad_cat", i,j, gradpepcat(1,j)
22716 !        iF (nstate(itypi,itypj).eq.1) THEN
22717       CALL sc_grad_cat
22718 !       print *,"after sc_grad_cat", i,j, gradpepcat(1,j)
22719
22720 !       END IF
22721 !c!-------------------------------------------------------------------
22722 !c! NAPISY KONCOWE
22723        END DO   ! j
22724        END DO     ! i
22725 !c      write (iout,*) "Number of loop steps in EGB:",ind
22726 !c      energy_dec=.false.
22727 !              print *,"EVDW KURW",evdw,nres
22728 !!!        return
22729    17   continue
22730 !      go to 23
22731       do i=ibond_start,ibond_end
22732
22733 !        print *,"I am in EVDW",i
22734       itypi=10 ! the peptide group parameters are for glicine
22735
22736 !        if (i.ne.47) cycle
22737       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
22738       itypi1=iabs(itype(i+1,1))
22739       xi=(c(1,i)+c(1,i+1))/2.0
22740       yi=(c(2,i)+c(2,i+1))/2.0
22741       zi=(c(3,i)+c(3,i+1))/2.0
22742         call to_box(xi,yi,zi)
22743       dxi=dc_norm(1,i)
22744       dyi=dc_norm(2,i)
22745       dzi=dc_norm(3,i)
22746       dsci_inv=vbld_inv(i+1)/2.0
22747        do j=itmp+1,itmp+nres_molec(5)
22748
22749 ! Calculate SC interaction energy.
22750           itypj=iabs(itype(j,5))
22751           if ((itypj.eq.ntyp1)) cycle
22752            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22753
22754           dscj_inv=0.0
22755          xj=c(1,j)
22756          yj=c(2,j)
22757          zj=c(3,j)
22758         call to_box(xj,yj,zj)
22759       xj=boxshift(xj-xi,boxxsize)
22760       yj=boxshift(yj-yi,boxysize)
22761       zj=boxshift(zj-zi,boxzsize)
22762
22763         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22764
22765         dxj = 0.0d0! dc_norm( 1, nres+j )
22766         dyj = 0.0d0!dc_norm( 2, nres+j )
22767         dzj = 0.0d0! dc_norm( 3, nres+j )
22768
22769         itypi = 10
22770         itypj = itype(j,5)
22771 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22772 ! sampling performed with amber package
22773 !          alf1   = 0.0d0
22774 !          alf2   = 0.0d0
22775 !          alf12  = 0.0d0
22776 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22777         chi1 = chi1cat(itypi,itypj)
22778         chis1 = chis1cat(itypi,itypj)
22779         chip1 = chipp1cat(itypi,itypj)
22780 !          chi1=0.0d0
22781 !          chis1=0.0d0
22782 !          chip1=0.0d0
22783         chi2=0.0
22784         chip2=0.0
22785         chis2=0.0
22786 !          chis2 = chis(itypj,itypi)
22787         chis12 = chis1 * chis2
22788         sig1 = sigmap1cat(itypi,itypj)
22789 !          sig2 = sigmap2(itypi,itypj)
22790 ! alpha factors from Fcav/Gcav
22791         b1cav = alphasurcat(1,itypi,itypj)
22792         b2cav = alphasurcat(2,itypi,itypj)
22793         b3cav = alphasurcat(3,itypi,itypj)
22794         b4cav = alphasurcat(4,itypi,itypj)
22795
22796 ! used to determine whether we want to do quadrupole calculations
22797        eps_in = epsintabcat(itypi,itypj)
22798        if (eps_in.eq.0.0) eps_in=1.0
22799
22800        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22801 !       Rtail = 0.0d0
22802
22803        DO k = 1, 3
22804       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
22805       ctail(k,2)=c(k,j)
22806        END DO
22807       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
22808       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
22809 !c! tail distances will be themselves usefull elswhere
22810 !c1 (in Gcav, for example)
22811        do k=1,3
22812        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
22813        enddo
22814
22815 !c! tail distances will be themselves usefull elswhere
22816 !c1 (in Gcav, for example)
22817        Rtail = dsqrt( &
22818         (Rtail_distance(1)*Rtail_distance(1)) &
22819       + (Rtail_distance(2)*Rtail_distance(2)) &
22820       + (Rtail_distance(3)*Rtail_distance(3)))
22821 ! tail location and distance calculations
22822 ! dhead1
22823        d1 = dheadcat(1, 1, itypi, itypj)
22824 !       print *,"d1",d1
22825 !       d1=0.0d0
22826 !       d2 = dhead(2, 1, itypi, itypj)
22827        DO k = 1,3
22828 ! location of polar head is computed by taking hydrophobic centre
22829 ! and moving by a d1 * dc_norm vector
22830 ! see unres publications for very informative images
22831       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
22832       chead(k,2) = c(k, j)
22833        ENDDO
22834 ! distance
22835 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22836 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22837       call to_box(chead(1,1),chead(2,1),chead(3,1))
22838       call to_box(chead(1,2),chead(2,2),chead(3,2))
22839
22840 ! distance
22841 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22842 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22843       do k=1,3
22844       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
22845        END DO
22846
22847 ! pitagoras (root of sum of squares)
22848        Rhead = dsqrt( &
22849         (Rhead_distance(1)*Rhead_distance(1)) &
22850       + (Rhead_distance(2)*Rhead_distance(2)) &
22851       + (Rhead_distance(3)*Rhead_distance(3)))
22852 !-------------------------------------------------------------------
22853 ! zero everything that should be zero'ed
22854        evdwij = 0.0d0
22855        ECL = 0.0d0
22856        Elj = 0.0d0
22857        Equad = 0.0d0
22858        Epol = 0.0d0
22859        Fcav=0.0d0
22860        eheadtail = 0.0d0
22861        dGCLdOM1 = 0.0d0
22862        dGCLdOM2 = 0.0d0
22863        dGCLdOM12 = 0.0d0
22864        dPOLdOM1 = 0.0d0
22865        dPOLdOM2 = 0.0d0
22866         Fcav = 0.0d0
22867         dFdR = 0.0d0
22868         dCAVdOM1  = 0.0d0
22869         dCAVdOM2  = 0.0d0
22870         dCAVdOM12 = 0.0d0
22871         dscj_inv = vbld_inv(j+nres)
22872 !          print *,i,j,dscj_inv,dsci_inv
22873 ! rij holds 1/(distance of Calpha atoms)
22874         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22875         rij  = dsqrt(rrij)
22876         CALL sc_angular
22877 ! this should be in elgrad_init but om's are calculated by sc_angular
22878 ! which in turn is used by older potentials
22879 ! om = omega, sqom = om^2
22880         sqom1  = om1 * om1
22881         sqom2  = om2 * om2
22882         sqom12 = om12 * om12
22883
22884 ! now we calculate EGB - Gey-Berne
22885 ! It will be summed up in evdwij and saved in evdw
22886         sigsq     = 1.0D0  / sigsq
22887         sig       = sig0ij * dsqrt(sigsq)
22888 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22889         rij_shift = Rtail - sig + sig0ij
22890         IF (rij_shift.le.0.0D0) THEN
22891          evdw = 1.0D20
22892 !      if (evdw.gt.1.0d6) then
22893 !      write (*,'(2(1x,a3,i3),6f6.2)') &
22894 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22895 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
22896 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22897 !      Equad,evdwij+Fcav+eheadtail,evdw
22898 !      endif
22899          RETURN
22900         END IF
22901         sigder = -sig * sigsq
22902         rij_shift = 1.0D0 / rij_shift
22903         fac       = rij_shift**expon
22904         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22905 !          print *,"ADAM",aa_aq(itypi,itypj)
22906
22907 !          c1        = 0.0d0
22908         c2        = fac  * bb_aq_cat(itypi,itypj)
22909 !          c2        = 0.0d0
22910         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22911         eps2der   = eps3rt * evdwij
22912         eps3der   = eps2rt * evdwij
22913 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22914         evdwij    = eps2rt * eps3rt * evdwij
22915 !#ifdef TSCSC
22916 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22917 !           evdw_p = evdw_p + evdwij
22918 !          ELSE
22919 !           evdw_m = evdw_m + evdwij
22920 !          END IF
22921 !#else
22922         evdw = evdw  &
22923             + evdwij
22924 !#endif
22925         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22926         fac    = -expon * (c1 + evdwij) * rij_shift
22927         sigder = fac * sigder
22928 ! Calculate distance derivative
22929         gg(1) =  fac
22930         gg(2) =  fac
22931         gg(3) =  fac
22932
22933         fac = chis1 * sqom1 + chis2 * sqom2 &
22934         - 2.0d0 * chis12 * om1 * om2 * om12
22935
22936         pom = 1.0d0 - chis1 * chis2 * sqom12
22937 !          print *,"TUT2",fac,chis1,sqom1,pom
22938         Lambf = (1.0d0 - (fac / pom))
22939         Lambf = dsqrt(Lambf)
22940         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22941         Chif = Rtail * sparrow
22942         ChiLambf = Chif * Lambf
22943         eagle = dsqrt(ChiLambf)
22944         bat = ChiLambf ** 11.0d0
22945         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22946         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22947         botsq = bot * bot
22948         Fcav = top / bot
22949
22950        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22951        dbot = 12.0d0 * b4cav * bat * Lambf
22952        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22953
22954         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22955         dbot = 12.0d0 * b4cav * bat * Chif
22956         eagle = Lambf * pom
22957         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22958         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22959         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22960             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22961
22962         dFdL = ((dtop * bot - top * dbot) / botsq)
22963         dCAVdOM1  = dFdL * ( dFdOM1 )
22964         dCAVdOM2  = dFdL * ( dFdOM2 )
22965         dCAVdOM12 = dFdL * ( dFdOM12 )
22966
22967        DO k= 1, 3
22968       ertail(k) = Rtail_distance(k)/Rtail
22969        END DO
22970        erdxi = scalar( ertail(1), dC_norm(1,i) )
22971        erdxj = scalar( ertail(1), dC_norm(1,j) )
22972        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
22973        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22974        DO k = 1, 3
22975       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
22976 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
22977 !                  - (( dFdR + gg(k) ) * pom)
22978       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22979 !        gvdwx(k,j) = gvdwx(k,j)   &
22980 !                  + (( dFdR + gg(k) ) * pom)
22981       gradpepcat(k,i) = gradpepcat(k,i)  &
22982               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22983       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
22984               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22985
22986       gradpepcat(k,j) = gradpepcat(k,j) &
22987               + (( dFdR + gg(k) ) * ertail(k))
22988       gg(k) = 0.0d0
22989        ENDDO
22990       if (itype(j,5).gt.0) then
22991 !c! Compute head-head and head-tail energies for each state
22992         isel = 3
22993 !c! Dipole-charge interactions
22994          CALL edq_cat_pep(ecl, elj, epol)
22995          eheadtail = ECL + elj + epol
22996 !          print *,"i,",i,eheadtail
22997 !           eheadtail = 0.0d0
22998       else
22999 !HERE WATER and other types of molecules solvents will be added
23000       write(iout,*) "not yet implemented"
23001 !      CALL edd_cat_pep
23002       endif
23003       evdw = evdw  + Fcav + eheadtail
23004 !      if (evdw.gt.1.0d6) then
23005 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23006 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23007 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23008 !      Equad,evdwij+Fcav+eheadtail,evdw
23009 !      endif
23010        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23011       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23012       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23013       Equad,evdwij+Fcav+eheadtail,evdw
23014 !       evdw = evdw  + Fcav  + eheadtail
23015
23016 !        iF (nstate(itypi,itypj).eq.1) THEN
23017       CALL sc_grad_cat_pep
23018 !       END IF
23019 !c!-------------------------------------------------------------------
23020 !c! NAPISY KONCOWE
23021        END DO   ! j
23022        END DO     ! i
23023 !c      write (iout,*) "Number of loop steps in EGB:",ind
23024 !c      energy_dec=.false.
23025 !              print *,"EVDW KURW",evdw,nres
23026  23   continue
23027 !       print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1)
23028
23029       return
23030       end subroutine ecats_prot_amber
23031
23032 !---------------------------------------------------------------------------
23033 ! old for Ca2+
23034        subroutine ecat_prot(ecation_prot)
23035 !      use calc_data
23036 !      use comm_momo
23037        integer i,j,k,subchap,itmp,inum
23038       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23039       r7,r4,ecationcation
23040       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23041       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23042       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23043       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23044       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23045       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23046       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23047       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23048       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23049       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23050       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23051       ndiv,ndivi
23052       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23053       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23054       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23055       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23056       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23057       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23058       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23059       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23060       dEvan1Cat
23061       real(kind=8),dimension(6) :: vcatprm
23062       ecation_prot=0.0d0
23063 ! first lets calculate interaction with peptide groups
23064       if (nres_molec(5).eq.0) return
23065       itmp=0
23066       do i=1,4
23067       itmp=itmp+nres_molec(i)
23068       enddo
23069 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23070       do i=ibond_start,ibond_end
23071 !         cycle
23072        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23073       xi=0.5d0*(c(1,i)+c(1,i+1))
23074       yi=0.5d0*(c(2,i)+c(2,i+1))
23075       zi=0.5d0*(c(3,i)+c(3,i+1))
23076         call to_box(xi,yi,zi)
23077
23078        do j=itmp+1,itmp+nres_molec(5)
23079 !           print *,"WTF",itmp,j,i
23080 ! all parameters were for Ca2+ to approximate single charge divide by two
23081        ndiv=1.0
23082        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23083        wconst=78*ndiv
23084       wdip =1.092777950857032D2
23085       wdip=wdip/wconst
23086       wmodquad=-2.174122713004870D4
23087       wmodquad=wmodquad/wconst
23088       wquad1 = 3.901232068562804D1
23089       wquad1=wquad1/wconst
23090       wquad2 = 3
23091       wquad2=wquad2/wconst
23092       wvan1 = 0.1
23093       wvan2 = 6
23094 !        itmp=0
23095
23096          xj=c(1,j)
23097          yj=c(2,j)
23098          zj=c(3,j)
23099         call to_box(xj,yj,zj)
23100       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23101 !       enddo
23102 !       enddo
23103        rcpm = sqrt(xj**2+yj**2+zj**2)
23104        drcp_norm(1)=xj/rcpm
23105        drcp_norm(2)=yj/rcpm
23106        drcp_norm(3)=zj/rcpm
23107        dcmag=0.0
23108        do k=1,3
23109        dcmag=dcmag+dc(k,i)**2
23110        enddo
23111        dcmag=dsqrt(dcmag)
23112        do k=1,3
23113        myd_norm(k)=dc(k,i)/dcmag
23114        enddo
23115       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23116       drcp_norm(3)*myd_norm(3)
23117       rsecp = rcpm**2
23118       Ir = 1.0d0/rcpm
23119       Irsecp = 1.0d0/rsecp
23120       Irthrp = Irsecp/rcpm
23121       Irfourp = Irthrp/rcpm
23122       Irfiftp = Irfourp/rcpm
23123       Irsistp=Irfiftp/rcpm
23124       Irseven=Irsistp/rcpm
23125       Irtwelv=Irsistp*Irsistp
23126       Irthir=Irtwelv/rcpm
23127       sin2thet = (1-costhet*costhet)
23128       sinthet=sqrt(sin2thet)
23129       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23130            *sin2thet
23131       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23132            2*wvan2**6*Irsistp)
23133       ecation_prot = ecation_prot+E1+E2
23134 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23135       dE1dr = -2*costhet*wdip*Irthrp-&
23136        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23137       dE2dr = 3*wquad1*wquad2*Irfourp-     &
23138         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23139       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23140       do k=1,3
23141         drdpep(k) = -drcp_norm(k)
23142         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23143         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23144         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23145         dEddci(k) = dEdcos*dcosddci(k)
23146       enddo
23147       do k=1,3
23148       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23149       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23150       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23151       enddo
23152        enddo ! j
23153        enddo ! i
23154 !------------------------------------------sidechains
23155 !        do i=1,nres_molec(1)
23156       do i=ibond_start,ibond_end
23157        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23158 !         cycle
23159 !        print *,i,ecation_prot
23160       xi=(c(1,i+nres))
23161       yi=(c(2,i+nres))
23162       zi=(c(3,i+nres))
23163                 call to_box(xi,yi,zi)
23164         do k=1,3
23165           cm1(k)=dc(k,i+nres)
23166         enddo
23167          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23168        do j=itmp+1,itmp+nres_molec(5)
23169        ndiv=1.0
23170        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23171
23172          xj=c(1,j)
23173          yj=c(2,j)
23174          zj=c(3,j)
23175         call to_box(xj,yj,zj)
23176       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23177 !       enddo
23178 !       enddo
23179 ! 15- Glu 16-Asp
23180        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23181        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23182        (itype(i,1).eq.25))) then
23183           if(itype(i,1).eq.16) then
23184           inum=1
23185           else
23186           inum=2
23187           endif
23188           do k=1,6
23189           vcatprm(k)=catprm(k,inum)
23190           enddo
23191           dASGL=catprm(7,inum)
23192 !             do k=1,3
23193 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23194             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23195             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23196             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23197
23198 !                valpha(k)=c(k,i)
23199 !                vcat(k)=c(k,j)
23200             if (subchap.eq.1) then
23201              vcat(1)=xj_temp
23202              vcat(2)=yj_temp
23203              vcat(3)=zj_temp
23204              else
23205             vcat(1)=xj_safe
23206             vcat(2)=yj_safe
23207             vcat(3)=zj_safe
23208              endif
23209             valpha(1)=xi-c(1,i+nres)+c(1,i)
23210             valpha(2)=yi-c(2,i+nres)+c(2,i)
23211             valpha(3)=zi-c(3,i+nres)+c(3,i)
23212
23213 !              enddo
23214       do k=1,3
23215         dx(k) = vcat(k)-vcm(k)
23216       enddo
23217       do k=1,3
23218         v1(k)=(vcm(k)-valpha(k))
23219         v2(k)=(vcat(k)-valpha(k))
23220       enddo
23221       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23222       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23223       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23224
23225 !  The weights of the energy function calculated from
23226 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23227         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23228           ndivi=0.5
23229         else
23230           ndivi=1.0
23231         endif
23232        ndiv=1.0
23233        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23234
23235       wh2o=78*ndivi*ndiv
23236       wc = vcatprm(1)
23237       wc=wc/wh2o
23238       wdip =vcatprm(2)
23239       wdip=wdip/wh2o
23240       wquad1 =vcatprm(3)
23241       wquad1=wquad1/wh2o
23242       wquad2 = vcatprm(4)
23243       wquad2=wquad2/wh2o
23244       wquad2p = 1.0d0-wquad2
23245       wvan1 = vcatprm(5)
23246       wvan2 =vcatprm(6)
23247       opt = dx(1)**2+dx(2)**2
23248       rsecp = opt+dx(3)**2
23249       rs = sqrt(rsecp)
23250       rthrp = rsecp*rs
23251       rfourp = rthrp*rs
23252       rsixp = rfourp*rsecp
23253       reight=rsixp*rsecp
23254       Ir = 1.0d0/rs
23255       Irsecp = 1.0d0/rsecp
23256       Irthrp = Irsecp/rs
23257       Irfourp = Irthrp/rs
23258       Irsixp = 1.0d0/rsixp
23259       Ireight=1.0d0/reight
23260       Irtw=Irsixp*Irsixp
23261       Irthir=Irtw/rs
23262       Irfourt=Irthir/rs
23263       opt1 = (4*rs*dx(3)*wdip)
23264       opt2 = 6*rsecp*wquad1*opt
23265       opt3 = wquad1*wquad2p*Irsixp
23266       opt4 = (wvan1*wvan2**12)
23267       opt5 = opt4*12*Irfourt
23268       opt6 = 2*wvan1*wvan2**6
23269       opt7 = 6*opt6*Ireight
23270       opt8 = wdip/v1m
23271       opt10 = wdip/v2m
23272       opt11 = (rsecp*v2m)**2
23273       opt12 = (rsecp*v1m)**2
23274       opt14 = (v1m*v2m*rsecp)**2
23275       opt15 = -wquad1/v2m**2
23276       opt16 = (rthrp*(v1m*v2m)**2)**2
23277       opt17 = (v1m**2*rthrp)**2
23278       opt18 = -wquad1/rthrp
23279       opt19 = (v1m**2*v2m**2)**2
23280       Ec = wc*Ir
23281       do k=1,3
23282         dEcCat(k) = -(dx(k)*wc)*Irthrp
23283         dEcCm(k)=(dx(k)*wc)*Irthrp
23284         dEcCalp(k)=0.0d0
23285       enddo
23286       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23287       do k=1,3
23288         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23289                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23290         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23291                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23292         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23293                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23294                   *v1dpv2)/opt14
23295       enddo
23296       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23297       do k=1,3
23298         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23299                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23300                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23301         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23302                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23303                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23304         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23305                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23306                   v1dpv2**2)/opt19
23307       enddo
23308       Equad2=wquad1*wquad2p*Irthrp
23309       do k=1,3
23310         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23311         dEquad2Cm(k)=3*dx(k)*rs*opt3
23312         dEquad2Calp(k)=0.0d0
23313       enddo
23314       Evan1=opt4*Irtw
23315       do k=1,3
23316         dEvan1Cat(k)=-dx(k)*opt5
23317         dEvan1Cm(k)=dx(k)*opt5
23318         dEvan1Calp(k)=0.0d0
23319       enddo
23320       Evan2=-opt6*Irsixp
23321       do k=1,3
23322         dEvan2Cat(k)=dx(k)*opt7
23323         dEvan2Cm(k)=-dx(k)*opt7
23324         dEvan2Calp(k)=0.0d0
23325       enddo
23326       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23327 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23328
23329       do k=1,3
23330         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23331                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23332 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23333         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23334                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23335         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23336                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23337       enddo
23338           dscmag = 0.0d0
23339           do k=1,3
23340             dscvec(k) = dc(k,i+nres)
23341             dscmag = dscmag+dscvec(k)*dscvec(k)
23342           enddo
23343           dscmag3 = dscmag
23344           dscmag = sqrt(dscmag)
23345           dscmag3 = dscmag3*dscmag
23346           constA = 1.0d0+dASGL/dscmag
23347           constB = 0.0d0
23348           do k=1,3
23349             constB = constB+dscvec(k)*dEtotalCm(k)
23350           enddo
23351           constB = constB*dASGL/dscmag3
23352           do k=1,3
23353             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23354             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23355              constA*dEtotalCm(k)-constB*dscvec(k)
23356 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23357             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23358             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23359            enddo
23360       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23361          if(itype(i,1).eq.14) then
23362           inum=3
23363           else
23364           inum=4
23365           endif
23366           do k=1,6
23367           vcatprm(k)=catprm(k,inum)
23368           enddo
23369           dASGL=catprm(7,inum)
23370 !             do k=1,3
23371 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23372 !                valpha(k)=c(k,i)
23373 !                vcat(k)=c(k,j)
23374 !              enddo
23375             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23376             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23377             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23378             if (subchap.eq.1) then
23379              vcat(1)=xj_temp
23380              vcat(2)=yj_temp
23381              vcat(3)=zj_temp
23382              else
23383             vcat(1)=xj_safe
23384             vcat(2)=yj_safe
23385             vcat(3)=zj_safe
23386             endif
23387             valpha(1)=xi-c(1,i+nres)+c(1,i)
23388             valpha(2)=yi-c(2,i+nres)+c(2,i)
23389             valpha(3)=zi-c(3,i+nres)+c(3,i)
23390
23391
23392       do k=1,3
23393         dx(k) = vcat(k)-vcm(k)
23394       enddo
23395       do k=1,3
23396         v1(k)=(vcm(k)-valpha(k))
23397         v2(k)=(vcat(k)-valpha(k))
23398       enddo
23399       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23400       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23401       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23402 !  The weights of the energy function calculated from
23403 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23404        ndiv=1.0
23405        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23406
23407       wh2o=78*ndiv
23408       wdip =vcatprm(2)
23409       wdip=wdip/wh2o
23410       wquad1 =vcatprm(3)
23411       wquad1=wquad1/wh2o
23412       wquad2 = vcatprm(4)
23413       wquad2=wquad2/wh2o
23414       wquad2p = 1-wquad2
23415       wvan1 = vcatprm(5)
23416       wvan2 =vcatprm(6)
23417       opt = dx(1)**2+dx(2)**2
23418       rsecp = opt+dx(3)**2
23419       rs = sqrt(rsecp)
23420       rthrp = rsecp*rs
23421       rfourp = rthrp*rs
23422       rsixp = rfourp*rsecp
23423       reight=rsixp*rsecp
23424       Ir = 1.0d0/rs
23425       Irsecp = 1/rsecp
23426       Irthrp = Irsecp/rs
23427       Irfourp = Irthrp/rs
23428       Irsixp = 1/rsixp
23429       Ireight=1/reight
23430       Irtw=Irsixp*Irsixp
23431       Irthir=Irtw/rs
23432       Irfourt=Irthir/rs
23433       opt1 = (4*rs*dx(3)*wdip)
23434       opt2 = 6*rsecp*wquad1*opt
23435       opt3 = wquad1*wquad2p*Irsixp
23436       opt4 = (wvan1*wvan2**12)
23437       opt5 = opt4*12*Irfourt
23438       opt6 = 2*wvan1*wvan2**6
23439       opt7 = 6*opt6*Ireight
23440       opt8 = wdip/v1m
23441       opt10 = wdip/v2m
23442       opt11 = (rsecp*v2m)**2
23443       opt12 = (rsecp*v1m)**2
23444       opt14 = (v1m*v2m*rsecp)**2
23445       opt15 = -wquad1/v2m**2
23446       opt16 = (rthrp*(v1m*v2m)**2)**2
23447       opt17 = (v1m**2*rthrp)**2
23448       opt18 = -wquad1/rthrp
23449       opt19 = (v1m**2*v2m**2)**2
23450       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23451       do k=1,3
23452         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23453                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23454        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23455                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23456         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23457                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23458                   *v1dpv2)/opt14
23459       enddo
23460       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23461       do k=1,3
23462         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23463                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23464                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23465         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23466                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23467                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23468         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23469                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23470                   v1dpv2**2)/opt19
23471       enddo
23472       Equad2=wquad1*wquad2p*Irthrp
23473       do k=1,3
23474         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23475         dEquad2Cm(k)=3*dx(k)*rs*opt3
23476         dEquad2Calp(k)=0.0d0
23477       enddo
23478       Evan1=opt4*Irtw
23479       do k=1,3
23480         dEvan1Cat(k)=-dx(k)*opt5
23481         dEvan1Cm(k)=dx(k)*opt5
23482         dEvan1Calp(k)=0.0d0
23483       enddo
23484       Evan2=-opt6*Irsixp
23485       do k=1,3
23486         dEvan2Cat(k)=dx(k)*opt7
23487         dEvan2Cm(k)=-dx(k)*opt7
23488         dEvan2Calp(k)=0.0d0
23489       enddo
23490        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23491       do k=1,3
23492         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23493                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23494         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23495                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23496         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23497                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23498       enddo
23499           dscmag = 0.0d0
23500           do k=1,3
23501             dscvec(k) = c(k,i+nres)-c(k,i)
23502 ! TU SPRAWDZ???
23503 !              dscvec(1) = xj
23504 !              dscvec(2) = yj
23505 !              dscvec(3) = zj
23506
23507             dscmag = dscmag+dscvec(k)*dscvec(k)
23508           enddo
23509           dscmag3 = dscmag
23510           dscmag = sqrt(dscmag)
23511           dscmag3 = dscmag3*dscmag
23512           constA = 1+dASGL/dscmag
23513           constB = 0.0d0
23514           do k=1,3
23515             constB = constB+dscvec(k)*dEtotalCm(k)
23516           enddo
23517           constB = constB*dASGL/dscmag3
23518           do k=1,3
23519             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23520             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23521              constA*dEtotalCm(k)-constB*dscvec(k)
23522             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23523             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23524            enddo
23525          else
23526           rcal = 0.0d0
23527           do k=1,3
23528 !              r(k) = c(k,j)-c(k,i+nres)
23529             r(1) = xj
23530             r(2) = yj
23531             r(3) = zj
23532             rcal = rcal+r(k)*r(k)
23533           enddo
23534           ract=sqrt(rcal)
23535           rocal=1.5
23536           epscalc=0.2
23537           r0p=0.5*(rocal+sig0(itype(i,1)))
23538           r06 = r0p**6
23539           r012 = r06*r06
23540           Evan1=epscalc*(r012/rcal**6)
23541           Evan2=epscalc*2*(r06/rcal**3)
23542           r4 = rcal**4
23543           r7 = rcal**7
23544           do k=1,3
23545             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23546             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23547           enddo
23548           do k=1,3
23549             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23550           enddo
23551              ecation_prot = ecation_prot+ Evan1+Evan2
23552           do  k=1,3
23553              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23554              dEtotalCm(k)
23555             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23556             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23557            enddo
23558        endif ! 13-16 residues
23559        enddo !j
23560        enddo !i
23561        return
23562        end subroutine ecat_prot
23563
23564 !----------------------------------------------------------------------------
23565 !---------------------------------------------------------------------------
23566        subroutine ecat_nucl(ecation_nucl)
23567        integer i,j,k,subchap,itmp,inum,itypi,itypj
23568        real(kind=8) :: xi,yi,zi,xj,yj,zj
23569        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23570        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
23571        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
23572        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
23573        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
23574        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
23575        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
23576        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
23577        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
23578        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
23579        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
23580        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
23581        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
23582        dEcavdCm,boxik
23583        real(kind=8),dimension(14) :: vcatnuclprm
23584        ecation_nucl=0.0d0
23585        boxik(1)=boxxsize
23586        boxik(2)=boxysize
23587        boxik(3)=boxzsize
23588
23589        if (nres_molec(5).eq.0) return
23590        itmp=0
23591        do i=1,4
23592           itmp=itmp+nres_molec(i)
23593        enddo
23594        do i=iatsc_s_nucl,iatsc_e_nucl
23595           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
23596           xi=(c(1,i+nres))
23597           yi=(c(2,i+nres))
23598           zi=(c(3,i+nres))
23599       call to_box(xi,yi,zi)
23600       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23601           do k=1,3
23602              cm1(k)=dc(k,i+nres)
23603           enddo
23604           do j=itmp+1,itmp+nres_molec(5)
23605              xj=c(1,j)
23606              yj=c(2,j)
23607              zj=c(3,j)
23608       call to_box(xj,yj,zj)
23609 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23610 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23611 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23612 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23613 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23614 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23615       xj=boxshift(xj-xi,boxxsize)
23616       yj=boxshift(yj-yi,boxysize)
23617       zj=boxshift(zj-zi,boxzsize)
23618 !       write(iout,*) 'after shift', xj,yj,zj
23619              dist_init=xj**2+yj**2+zj**2
23620
23621              itypi=itype(i,2)
23622              itypj=itype(j,5)
23623              do k=1,13
23624                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
23625              enddo
23626              do k=1,3
23627                 vcm(k)=c(k,i+nres)
23628                 vsug(k)=c(k,i)
23629                 vcat(k)=c(k,j)
23630              enddo
23631              call to_box(vcm(1),vcm(2),vcm(3))
23632              call to_box(vsug(1),vsug(2),vsug(3))
23633              call to_box(vcat(1),vcat(2),vcat(3))
23634              do k=1,3
23635 !                dx(k) = vcat(k)-vcm(k)
23636 !             enddo
23637                 dx(k)=boxshift(vcat(k)-vcm(k),boxik(k))
23638 !             do k=1,3
23639                 v1(k)=dc(k,i+nres)
23640                 v2(k)=boxshift(vcat(k)-vsug(k),boxik(k))
23641              enddo
23642              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23643              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
23644 !  The weights of the energy function calculated from
23645 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
23646              wh2o=78
23647              wdip1 = vcatnuclprm(1)
23648              wdip1 = wdip1/wh2o                     !w1
23649              wdip2 = vcatnuclprm(2)
23650              wdip2 = wdip2/wh2o                     !w2
23651              wvan1 = vcatnuclprm(3)
23652              wvan2 = vcatnuclprm(4)                 !pis1
23653              wgbsig = vcatnuclprm(5)                !sigma0
23654              wgbeps = vcatnuclprm(6)                !epsi0
23655              wgbchi = vcatnuclprm(7)                !chi1
23656              wgbchip = vcatnuclprm(8)               !chip1
23657              wcavsig = vcatnuclprm(9)               !sig
23658              wcav1 = vcatnuclprm(10)                !b1
23659              wcav2 = vcatnuclprm(11)                !b2
23660              wcav3 = vcatnuclprm(12)                !b3
23661              wcav4 = vcatnuclprm(13)                !b4
23662              wcavchi = vcatnuclprm(14)              !chis1
23663              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
23664              invrcs6 = 1/rcs2**3
23665              invrcs8 = invrcs6/rcs2
23666              invrcs12 = invrcs6**2
23667              invrcs14 = invrcs12/rcs2
23668              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
23669              rcb = sqrt(rcb2)
23670              invrcb = 1/rcb
23671              invrcb2 = invrcb**2
23672              invrcb4 = invrcb2**2
23673              invrcb6 = invrcb4*invrcb2
23674              cosinus = v1dpdx/(v1m*rcb)
23675              cos2 = cosinus**2
23676              dcosdcatconst = invrcb2/v1m
23677              dcosdcalpconst = invrcb/v1m**2
23678              dcosdcmconst = invrcb2/v1m**2
23679              do k=1,3
23680                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
23681                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
23682                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
23683                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
23684              enddo
23685              rcav = rcb/wcavsig
23686              rcav11 = rcav**11
23687              rcav12 = rcav11*rcav
23688              constcav1 = 1-wcavchi*cos2
23689              constcav2 = sqrt(constcav1)
23690              constgb1 = 1/sqrt(1-wgbchi*cos2)
23691              constgb2 = wgbeps*(1-wgbchip*cos2)**2
23692              constdvan1 = 12*wvan1*wvan2**12*invrcs14
23693              constdvan2 = 6*wvan1*wvan2**6*invrcs8
23694 !----------------------------------------------------------------------------
23695 !Gay-Berne term
23696 !---------------------------------------------------------------------------
23697              sgb = 1/(1-constgb1+(rcb/wgbsig))
23698              sgb6 = sgb**6
23699              sgb7 = sgb6*sgb
23700              sgb12 = sgb6**2
23701              sgb13 = sgb12*sgb
23702              Egb = constgb2*(sgb12-sgb6)
23703              do k=1,3
23704                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23705                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23706      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
23707                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23708                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23709      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
23710                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
23711                                *(12*sgb13-6*sgb7) &
23712      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
23713              enddo
23714 !----------------------------------------------------------------------------
23715 !cavity term
23716 !---------------------------------------------------------------------------
23717              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
23718              cavdenom = 1+wcav4*rcav12*constcav1**6
23719              Ecav = wcav1*cavnum/cavdenom
23720              invcavdenom2 = 1/cavdenom**2
23721              dcavnumdcos = -wcavchi*cosinus/constcav2 &
23722                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
23723              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
23724              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
23725              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
23726              do k=1,3
23727                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23728      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23729                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23730      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23731                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23732                              *dcosdcalp(k)*wcav1*invcavdenom2
23733              enddo
23734 !----------------------------------------------------------------------------
23735 !van der Waals and dipole-charge interaction energy
23736 !---------------------------------------------------------------------------
23737              Evan1 = wvan1*wvan2**12*invrcs12
23738              do k=1,3
23739                 dEvan1Cat(k) = -v2(k)*constdvan1
23740                 dEvan1Cm(k) = 0.0d0
23741                 dEvan1Calp(k) = v2(k)*constdvan1
23742              enddo
23743              Evan2 = -wvan1*wvan2**6*invrcs6
23744              do k=1,3
23745                 dEvan2Cat(k) = v2(k)*constdvan2
23746                 dEvan2Cm(k) = 0.0d0
23747                 dEvan2Calp(k) = -v2(k)*constdvan2
23748              enddo
23749              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
23750              do k=1,3
23751                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
23752                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23753                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23754                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
23755                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23756                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23757                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
23758                                   +2*wdip2*cosinus*invrcb4)
23759              enddo
23760              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
23761          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
23762              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
23763              do k=1,3
23764                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
23765                                              +dEgbdCat(k)+dEdipCat(k)
23766                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
23767                                            +dEgbdCm(k)+dEdipCm(k)
23768                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
23769                                              +dEdipCalp(k)+dEvan2Calp(k)
23770              enddo
23771              do k=1,3
23772                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23773                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
23774                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
23775                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
23776              enddo
23777           enddo !j
23778        enddo !i
23779        return
23780        end subroutine ecat_nucl
23781
23782 !-----------------------------------------------------------------------------
23783 !-----------------------------------------------------------------------------
23784       subroutine eprot_sc_base(escbase)
23785       use calc_data
23786 !      implicit real*8 (a-h,o-z)
23787 !      include 'DIMENSIONS'
23788 !      include 'COMMON.GEO'
23789 !      include 'COMMON.VAR'
23790 !      include 'COMMON.LOCAL'
23791 !      include 'COMMON.CHAIN'
23792 !      include 'COMMON.DERIV'
23793 !      include 'COMMON.NAMES'
23794 !      include 'COMMON.INTERACT'
23795 !      include 'COMMON.IOUNITS'
23796 !      include 'COMMON.CALC'
23797 !      include 'COMMON.CONTROL'
23798 !      include 'COMMON.SBRIDGE'
23799       logical :: lprn
23800 !el local variables
23801       integer :: iint,itypi,itypi1,itypj,subchap
23802       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23803       real(kind=8) :: evdw,sig0ij
23804       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23805                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23806                 sslipi,sslipj,faclip
23807       integer :: ii
23808       real(kind=8) :: fracinbuf
23809        real (kind=8) :: escbase
23810        real (kind=8),dimension(4):: ener
23811        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23812        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23813       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23814       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23815       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23816       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23817       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23818       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23819        real(kind=8),dimension(3,2)::chead,erhead_tail
23820        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23821        integer troll
23822        eps_out=80.0d0
23823        escbase=0.0d0
23824 !       do i=1,nres_molec(1)
23825       do i=ibond_start,ibond_end
23826       if (itype(i,1).eq.ntyp1_molec(1)) cycle
23827       itypi  = itype(i,1)
23828       dxi    = dc_norm(1,nres+i)
23829       dyi    = dc_norm(2,nres+i)
23830       dzi    = dc_norm(3,nres+i)
23831       dsci_inv = vbld_inv(i+nres)
23832       xi=c(1,nres+i)
23833       yi=c(2,nres+i)
23834       zi=c(3,nres+i)
23835       call to_box(xi,yi,zi)
23836       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23837        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23838          itypj= itype(j,2)
23839          if (itype(j,2).eq.ntyp1_molec(2))cycle
23840          xj=c(1,j+nres)
23841          yj=c(2,j+nres)
23842          zj=c(3,j+nres)
23843       call to_box(xj,yj,zj)
23844 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23845 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23846 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23847 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23848 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23849       xj=boxshift(xj-xi,boxxsize)
23850       yj=boxshift(yj-yi,boxysize)
23851       zj=boxshift(zj-zi,boxzsize)
23852
23853         dxj = dc_norm( 1, nres+j )
23854         dyj = dc_norm( 2, nres+j )
23855         dzj = dc_norm( 3, nres+j )
23856 !          print *,i,j,itypi,itypj
23857         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23858         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23859 !          d1i=0.0d0
23860 !          d1j=0.0d0
23861 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23862 ! Gay-berne var's
23863         sig0ij = sigma_scbase( itypi,itypj )
23864         chi1   = chi_scbase( itypi, itypj,1 )
23865         chi2   = chi_scbase( itypi, itypj,2 )
23866 !          chi1=0.0d0
23867 !          chi2=0.0d0
23868         chi12  = chi1 * chi2
23869         chip1  = chipp_scbase( itypi, itypj,1 )
23870         chip2  = chipp_scbase( itypi, itypj,2 )
23871 !          chip1=0.0d0
23872 !          chip2=0.0d0
23873         chip12 = chip1 * chip2
23874 ! not used by momo potential, but needed by sc_angular which is shared
23875 ! by all energy_potential subroutines
23876         alf1   = 0.0d0
23877         alf2   = 0.0d0
23878         alf12  = 0.0d0
23879         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23880 !       a12sq = a12sq * a12sq
23881 ! charge of amino acid itypi is...
23882         chis1 = chis_scbase(itypi,itypj,1)
23883         chis2 = chis_scbase(itypi,itypj,2)
23884         chis12 = chis1 * chis2
23885         sig1 = sigmap1_scbase(itypi,itypj)
23886         sig2 = sigmap2_scbase(itypi,itypj)
23887 !       write (*,*) "sig1 = ", sig1
23888 !       write (*,*) "sig2 = ", sig2
23889 ! alpha factors from Fcav/Gcav
23890         b1 = alphasur_scbase(1,itypi,itypj)
23891 !          b1=0.0d0
23892         b2 = alphasur_scbase(2,itypi,itypj)
23893         b3 = alphasur_scbase(3,itypi,itypj)
23894         b4 = alphasur_scbase(4,itypi,itypj)
23895 ! used to determine whether we want to do quadrupole calculations
23896 ! used by Fgb
23897        eps_in = epsintab_scbase(itypi,itypj)
23898        if (eps_in.eq.0.0) eps_in=1.0
23899        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23900 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23901 !-------------------------------------------------------------------
23902 ! tail location and distance calculations
23903        DO k = 1,3
23904 ! location of polar head is computed by taking hydrophobic centre
23905 ! and moving by a d1 * dc_norm vector
23906 ! see unres publications for very informative images
23907       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23908       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23909 ! distance
23910 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23911 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23912       Rhead_distance(k) = chead(k,2) - chead(k,1)
23913        END DO
23914 ! pitagoras (root of sum of squares)
23915        Rhead = dsqrt( &
23916         (Rhead_distance(1)*Rhead_distance(1)) &
23917       + (Rhead_distance(2)*Rhead_distance(2)) &
23918       + (Rhead_distance(3)*Rhead_distance(3)))
23919 !-------------------------------------------------------------------
23920 ! zero everything that should be zero'ed
23921        evdwij = 0.0d0
23922        ECL = 0.0d0
23923        Elj = 0.0d0
23924        Equad = 0.0d0
23925        Epol = 0.0d0
23926        Fcav=0.0d0
23927        eheadtail = 0.0d0
23928        dGCLdOM1 = 0.0d0
23929        dGCLdOM2 = 0.0d0
23930        dGCLdOM12 = 0.0d0
23931        dPOLdOM1 = 0.0d0
23932        dPOLdOM2 = 0.0d0
23933         Fcav = 0.0d0
23934         dFdR = 0.0d0
23935         dCAVdOM1  = 0.0d0
23936         dCAVdOM2  = 0.0d0
23937         dCAVdOM12 = 0.0d0
23938         dscj_inv = vbld_inv(j+nres)
23939 !          print *,i,j,dscj_inv,dsci_inv
23940 ! rij holds 1/(distance of Calpha atoms)
23941         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23942         rij  = dsqrt(rrij)
23943 !----------------------------
23944         CALL sc_angular
23945 ! this should be in elgrad_init but om's are calculated by sc_angular
23946 ! which in turn is used by older potentials
23947 ! om = omega, sqom = om^2
23948         sqom1  = om1 * om1
23949         sqom2  = om2 * om2
23950         sqom12 = om12 * om12
23951
23952 ! now we calculate EGB - Gey-Berne
23953 ! It will be summed up in evdwij and saved in evdw
23954         sigsq     = 1.0D0  / sigsq
23955         sig       = sig0ij * dsqrt(sigsq)
23956 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23957         rij_shift = 1.0/rij - sig + sig0ij
23958         IF (rij_shift.le.0.0D0) THEN
23959          evdw = 1.0D20
23960          RETURN
23961         END IF
23962         sigder = -sig * sigsq
23963         rij_shift = 1.0D0 / rij_shift
23964         fac       = rij_shift**expon
23965         c1        = fac  * fac * aa_scbase(itypi,itypj)
23966 !          c1        = 0.0d0
23967         c2        = fac  * bb_scbase(itypi,itypj)
23968 !          c2        = 0.0d0
23969         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23970         eps2der   = eps3rt * evdwij
23971         eps3der   = eps2rt * evdwij
23972 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23973         evdwij    = eps2rt * eps3rt * evdwij
23974         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23975         fac    = -expon * (c1 + evdwij) * rij_shift
23976         sigder = fac * sigder
23977 !          fac    = rij * fac
23978 ! Calculate distance derivative
23979         gg(1) =  fac
23980         gg(2) =  fac
23981         gg(3) =  fac
23982 !          if (b2.gt.0.0) then
23983         fac = chis1 * sqom1 + chis2 * sqom2 &
23984         - 2.0d0 * chis12 * om1 * om2 * om12
23985 ! we will use pom later in Gcav, so dont mess with it!
23986         pom = 1.0d0 - chis1 * chis2 * sqom12
23987         Lambf = (1.0d0 - (fac / pom))
23988         Lambf = dsqrt(Lambf)
23989         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23990 !       write (*,*) "sparrow = ", sparrow
23991         Chif = 1.0d0/rij * sparrow
23992         ChiLambf = Chif * Lambf
23993         eagle = dsqrt(ChiLambf)
23994         bat = ChiLambf ** 11.0d0
23995         top = b1 * ( eagle + b2 * ChiLambf - b3 )
23996         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23997         botsq = bot * bot
23998         Fcav = top / bot
23999 !          print *,i,j,Fcav
24000         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24001         dbot = 12.0d0 * b4 * bat * Lambf
24002         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24003 !       dFdR = 0.0d0
24004 !      write (*,*) "dFcav/dR = ", dFdR
24005         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24006         dbot = 12.0d0 * b4 * bat * Chif
24007         eagle = Lambf * pom
24008         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24009         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24010         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24011             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24012
24013         dFdL = ((dtop * bot - top * dbot) / botsq)
24014 !       dFdL = 0.0d0
24015         dCAVdOM1  = dFdL * ( dFdOM1 )
24016         dCAVdOM2  = dFdL * ( dFdOM2 )
24017         dCAVdOM12 = dFdL * ( dFdOM12 )
24018
24019         ertail(1) = xj*rij
24020         ertail(2) = yj*rij
24021         ertail(3) = zj*rij
24022 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24023 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24024 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24025 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24026 !           print *,"EOMY",eom1,eom2,eom12
24027 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24028 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24029 ! here dtail=0.0
24030 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24031 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24032        DO k = 1, 3
24033 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24034 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24035       pom = ertail(k)
24036 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24037       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24038               - (( dFdR + gg(k) ) * pom)
24039 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24040 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24041 !     &             - ( dFdR * pom )
24042       pom = ertail(k)
24043 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24044       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24045               + (( dFdR + gg(k) ) * pom)
24046 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24047 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24048 !c!     &             + ( dFdR * pom )
24049
24050       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24051               - (( dFdR + gg(k) ) * ertail(k))
24052 !c!     &             - ( dFdR * ertail(k))
24053
24054       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24055               + (( dFdR + gg(k) ) * ertail(k))
24056 !c!     &             + ( dFdR * ertail(k))
24057
24058       gg(k) = 0.0d0
24059 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24060 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24061       END DO
24062
24063 !          else
24064
24065 !          endif
24066 !Now dipole-dipole
24067        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24068        w1 = wdipdip_scbase(1,itypi,itypj)
24069        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24070        w3 = wdipdip_scbase(2,itypi,itypj)
24071 !c!-------------------------------------------------------------------
24072 !c! ECL
24073        fac = (om12 - 3.0d0 * om1 * om2)
24074        c1 = (w1 / (Rhead**3.0d0)) * fac
24075        c2 = (w2 / Rhead ** 6.0d0)  &
24076        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24077        c3= (w3/ Rhead ** 6.0d0)  &
24078        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24079        ECL = c1 - c2 + c3
24080 !c!       write (*,*) "w1 = ", w1
24081 !c!       write (*,*) "w2 = ", w2
24082 !c!       write (*,*) "om1 = ", om1
24083 !c!       write (*,*) "om2 = ", om2
24084 !c!       write (*,*) "om12 = ", om12
24085 !c!       write (*,*) "fac = ", fac
24086 !c!       write (*,*) "c1 = ", c1
24087 !c!       write (*,*) "c2 = ", c2
24088 !c!       write (*,*) "Ecl = ", Ecl
24089 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24090 !c!       write (*,*) "c2_2 = ",
24091 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24092 !c!-------------------------------------------------------------------
24093 !c! dervative of ECL is GCL...
24094 !c! dECL/dr
24095        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24096        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24097        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24098        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24099        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24100        dGCLdR = c1 - c2 + c3
24101 !c! dECL/dom1
24102        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24103        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24104        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24105        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24106        dGCLdOM1 = c1 - c2 + c3
24107 !c! dECL/dom2
24108        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24109        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24110        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24111        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24112        dGCLdOM2 = c1 - c2 + c3
24113 !c! dECL/dom12
24114        c1 = w1 / (Rhead ** 3.0d0)
24115        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24116        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24117        dGCLdOM12 = c1 - c2 + c3
24118        DO k= 1, 3
24119       erhead(k) = Rhead_distance(k)/Rhead
24120        END DO
24121        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24122        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24123        facd1 = d1i * vbld_inv(i+nres)
24124        facd2 = d1j * vbld_inv(j+nres)
24125        DO k = 1, 3
24126
24127       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24128       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24129               - dGCLdR * pom
24130       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24131       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24132               + dGCLdR * pom
24133
24134       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24135               - dGCLdR * erhead(k)
24136       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24137               + dGCLdR * erhead(k)
24138        END DO
24139        endif
24140 !now charge with dipole eg. ARG-dG
24141        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24142       alphapol1 = alphapol_scbase(itypi,itypj)
24143        w1        = wqdip_scbase(1,itypi,itypj)
24144        w2        = wqdip_scbase(2,itypi,itypj)
24145 !       w1=0.0d0
24146 !       w2=0.0d0
24147 !       pis       = sig0head_scbase(itypi,itypj)
24148 !       eps_head   = epshead_scbase(itypi,itypj)
24149 !c!-------------------------------------------------------------------
24150 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24151        R1 = 0.0d0
24152        DO k = 1, 3
24153 !c! Calculate head-to-tail distances tail is center of side-chain
24154       R1=R1+(c(k,j+nres)-chead(k,1))**2
24155        END DO
24156 !c! Pitagoras
24157        R1 = dsqrt(R1)
24158
24159 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24160 !c!     &        +dhead(1,1,itypi,itypj))**2))
24161 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24162 !c!     &        +dhead(2,1,itypi,itypj))**2))
24163
24164 !c!-------------------------------------------------------------------
24165 !c! ecl
24166        sparrow  = w1  *  om1
24167        hawk     = w2 *  (1.0d0 - sqom2)
24168        Ecl = sparrow / Rhead**2.0d0 &
24169          - hawk    / Rhead**4.0d0
24170 !c!-------------------------------------------------------------------
24171 !c! derivative of ecl is Gcl
24172 !c! dF/dr part
24173        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24174             + 4.0d0 * hawk    / Rhead**5.0d0
24175 !c! dF/dom1
24176        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24177 !c! dF/dom2
24178        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24179 !c--------------------------------------------------------------------
24180 !c Polarization energy
24181 !c Epol
24182        MomoFac1 = (1.0d0 - chi1 * sqom2)
24183        RR1  = R1 * R1 / MomoFac1
24184        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24185        fgb1 = sqrt( RR1 + a12sq * ee1)
24186 !       eps_inout_fac=0.0d0
24187        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24188 ! derivative of Epol is Gpol...
24189        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24190             / (fgb1 ** 5.0d0)
24191        dFGBdR1 = ( (R1 / MomoFac1) &
24192            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24193            / ( 2.0d0 * fgb1 )
24194        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24195              * (2.0d0 - 0.5d0 * ee1) ) &
24196              / (2.0d0 * fgb1)
24197        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24198 !       dPOLdR1 = 0.0d0
24199        dPOLdOM1 = 0.0d0
24200        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24201        DO k = 1, 3
24202       erhead(k) = Rhead_distance(k)/Rhead
24203       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24204        END DO
24205
24206        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24207        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24208        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24209 !       bat=0.0d0
24210        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24211        facd1 = d1i * vbld_inv(i+nres)
24212        facd2 = d1j * vbld_inv(j+nres)
24213 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24214
24215        DO k = 1, 3
24216       hawk = (erhead_tail(k,1) + &
24217       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24218 !        facd1=0.0d0
24219 !        facd2=0.0d0
24220       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24221       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24222                - dGCLdR * pom &
24223                - dPOLdR1 *  (erhead_tail(k,1))
24224 !     &             - dGLJdR * pom
24225
24226       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24227       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24228                + dGCLdR * pom  &
24229                + dPOLdR1 * (erhead_tail(k,1))
24230 !     &             + dGLJdR * pom
24231
24232
24233       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24234               - dGCLdR * erhead(k) &
24235               - dPOLdR1 * erhead_tail(k,1)
24236 !     &             - dGLJdR * erhead(k)
24237
24238       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24239               + dGCLdR * erhead(k)  &
24240               + dPOLdR1 * erhead_tail(k,1)
24241 !     &             + dGLJdR * erhead(k)
24242
24243        END DO
24244        endif
24245 !       print *,i,j,evdwij,epol,Fcav,ECL
24246        escbase=escbase+evdwij+epol+Fcav+ECL
24247        call sc_grad_scbase
24248        enddo
24249       enddo
24250
24251       return
24252       end subroutine eprot_sc_base
24253       SUBROUTINE sc_grad_scbase
24254       use calc_data
24255
24256        real (kind=8) :: dcosom1(3),dcosom2(3)
24257        eom1  =    &
24258             eps2der * eps2rt_om1   &
24259           - 2.0D0 * alf1 * eps3der &
24260           + sigder * sigsq_om1     &
24261           + dCAVdOM1               &
24262           + dGCLdOM1               &
24263           + dPOLdOM1
24264
24265        eom2  =  &
24266             eps2der * eps2rt_om2   &
24267           + 2.0D0 * alf2 * eps3der &
24268           + sigder * sigsq_om2     &
24269           + dCAVdOM2               &
24270           + dGCLdOM2               &
24271           + dPOLdOM2
24272
24273        eom12 =    &
24274             evdwij  * eps1_om12     &
24275           + eps2der * eps2rt_om12   &
24276           - 2.0D0 * alf12 * eps3der &
24277           + sigder *sigsq_om12      &
24278           + dCAVdOM12               &
24279           + dGCLdOM12
24280
24281 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24282 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24283 !               gg(1),gg(2),"rozne"
24284        DO k = 1, 3
24285       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24286       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24287       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24288       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24289              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24290              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24291       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24292              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24293              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24294       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24295       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24296        END DO
24297        RETURN
24298       END SUBROUTINE sc_grad_scbase
24299
24300
24301       subroutine epep_sc_base(epepbase)
24302       use calc_data
24303       logical :: lprn
24304 !el local variables
24305       integer :: iint,itypi,itypi1,itypj,subchap
24306       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24307       real(kind=8) :: evdw,sig0ij
24308       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24309                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24310                 sslipi,sslipj,faclip
24311       integer :: ii
24312       real(kind=8) :: fracinbuf
24313        real (kind=8) :: epepbase
24314        real (kind=8),dimension(4):: ener
24315        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24316        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24317       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24318       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24319       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24320       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24321       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24322       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24323        real(kind=8),dimension(3,2)::chead,erhead_tail
24324        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24325        integer troll
24326        eps_out=80.0d0
24327        epepbase=0.0d0
24328 !       do i=1,nres_molec(1)-1
24329       do i=ibond_start,ibond_end
24330       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24331 !C        itypi  = itype(i,1)
24332       dxi    = dc_norm(1,i)
24333       dyi    = dc_norm(2,i)
24334       dzi    = dc_norm(3,i)
24335 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24336       dsci_inv = vbld_inv(i+1)/2.0
24337       xi=(c(1,i)+c(1,i+1))/2.0
24338       yi=(c(2,i)+c(2,i+1))/2.0
24339       zi=(c(3,i)+c(3,i+1))/2.0
24340         call to_box(xi,yi,zi)
24341        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24342          itypj= itype(j,2)
24343          if (itype(j,2).eq.ntyp1_molec(2))cycle
24344          xj=c(1,j+nres)
24345          yj=c(2,j+nres)
24346          zj=c(3,j+nres)
24347                 call to_box(xj,yj,zj)
24348       xj=boxshift(xj-xi,boxxsize)
24349       yj=boxshift(yj-yi,boxysize)
24350       zj=boxshift(zj-zi,boxzsize)
24351         dist_init=xj**2+yj**2+zj**2
24352         dxj = dc_norm( 1, nres+j )
24353         dyj = dc_norm( 2, nres+j )
24354         dzj = dc_norm( 3, nres+j )
24355 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24356 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24357
24358 ! Gay-berne var's
24359         sig0ij = sigma_pepbase(itypj )
24360         chi1   = chi_pepbase(itypj,1 )
24361         chi2   = chi_pepbase(itypj,2 )
24362 !          chi1=0.0d0
24363 !          chi2=0.0d0
24364         chi12  = chi1 * chi2
24365         chip1  = chipp_pepbase(itypj,1 )
24366         chip2  = chipp_pepbase(itypj,2 )
24367 !          chip1=0.0d0
24368 !          chip2=0.0d0
24369         chip12 = chip1 * chip2
24370         chis1 = chis_pepbase(itypj,1)
24371         chis2 = chis_pepbase(itypj,2)
24372         chis12 = chis1 * chis2
24373         sig1 = sigmap1_pepbase(itypj)
24374         sig2 = sigmap2_pepbase(itypj)
24375 !       write (*,*) "sig1 = ", sig1
24376 !       write (*,*) "sig2 = ", sig2
24377        DO k = 1,3
24378 ! location of polar head is computed by taking hydrophobic centre
24379 ! and moving by a d1 * dc_norm vector
24380 ! see unres publications for very informative images
24381       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24382 ! + d1i * dc_norm(k, i+nres)
24383       chead(k,2) = c(k, j+nres)
24384 ! + d1j * dc_norm(k, j+nres)
24385 ! distance
24386 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24387 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24388       Rhead_distance(k) = chead(k,2) - chead(k,1)
24389 !        print *,gvdwc_pepbase(k,i)
24390
24391        END DO
24392        Rhead = dsqrt( &
24393         (Rhead_distance(1)*Rhead_distance(1)) &
24394       + (Rhead_distance(2)*Rhead_distance(2)) &
24395       + (Rhead_distance(3)*Rhead_distance(3)))
24396
24397 ! alpha factors from Fcav/Gcav
24398         b1 = alphasur_pepbase(1,itypj)
24399 !          b1=0.0d0
24400         b2 = alphasur_pepbase(2,itypj)
24401         b3 = alphasur_pepbase(3,itypj)
24402         b4 = alphasur_pepbase(4,itypj)
24403         alf1   = 0.0d0
24404         alf2   = 0.0d0
24405         alf12  = 0.0d0
24406         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24407 !          print *,i,j,rrij
24408         rij  = dsqrt(rrij)
24409 !----------------------------
24410        evdwij = 0.0d0
24411        ECL = 0.0d0
24412        Elj = 0.0d0
24413        Equad = 0.0d0
24414        Epol = 0.0d0
24415        Fcav=0.0d0
24416        eheadtail = 0.0d0
24417        dGCLdOM1 = 0.0d0
24418        dGCLdOM2 = 0.0d0
24419        dGCLdOM12 = 0.0d0
24420        dPOLdOM1 = 0.0d0
24421        dPOLdOM2 = 0.0d0
24422         Fcav = 0.0d0
24423         dFdR = 0.0d0
24424         dCAVdOM1  = 0.0d0
24425         dCAVdOM2  = 0.0d0
24426         dCAVdOM12 = 0.0d0
24427         dscj_inv = vbld_inv(j+nres)
24428         CALL sc_angular
24429 ! this should be in elgrad_init but om's are calculated by sc_angular
24430 ! which in turn is used by older potentials
24431 ! om = omega, sqom = om^2
24432         sqom1  = om1 * om1
24433         sqom2  = om2 * om2
24434         sqom12 = om12 * om12
24435
24436 ! now we calculate EGB - Gey-Berne
24437 ! It will be summed up in evdwij and saved in evdw
24438         sigsq     = 1.0D0  / sigsq
24439         sig       = sig0ij * dsqrt(sigsq)
24440         rij_shift = 1.0/rij - sig + sig0ij
24441         IF (rij_shift.le.0.0D0) THEN
24442          evdw = 1.0D20
24443          RETURN
24444         END IF
24445         sigder = -sig * sigsq
24446         rij_shift = 1.0D0 / rij_shift
24447         fac       = rij_shift**expon
24448         c1        = fac  * fac * aa_pepbase(itypj)
24449 !          c1        = 0.0d0
24450         c2        = fac  * bb_pepbase(itypj)
24451 !          c2        = 0.0d0
24452         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24453         eps2der   = eps3rt * evdwij
24454         eps3der   = eps2rt * evdwij
24455 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24456         evdwij    = eps2rt * eps3rt * evdwij
24457         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24458         fac    = -expon * (c1 + evdwij) * rij_shift
24459         sigder = fac * sigder
24460 !          fac    = rij * fac
24461 ! Calculate distance derivative
24462         gg(1) =  fac
24463         gg(2) =  fac
24464         gg(3) =  fac
24465         fac = chis1 * sqom1 + chis2 * sqom2 &
24466         - 2.0d0 * chis12 * om1 * om2 * om12
24467 ! we will use pom later in Gcav, so dont mess with it!
24468         pom = 1.0d0 - chis1 * chis2 * sqom12
24469         Lambf = (1.0d0 - (fac / pom))
24470         Lambf = dsqrt(Lambf)
24471         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24472 !       write (*,*) "sparrow = ", sparrow
24473         Chif = 1.0d0/rij * sparrow
24474         ChiLambf = Chif * Lambf
24475         eagle = dsqrt(ChiLambf)
24476         bat = ChiLambf ** 11.0d0
24477         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24478         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24479         botsq = bot * bot
24480         Fcav = top / bot
24481 !          print *,i,j,Fcav
24482         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24483         dbot = 12.0d0 * b4 * bat * Lambf
24484         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24485 !       dFdR = 0.0d0
24486 !      write (*,*) "dFcav/dR = ", dFdR
24487         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24488         dbot = 12.0d0 * b4 * bat * Chif
24489         eagle = Lambf * pom
24490         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24491         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24492         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24493             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24494
24495         dFdL = ((dtop * bot - top * dbot) / botsq)
24496 !       dFdL = 0.0d0
24497         dCAVdOM1  = dFdL * ( dFdOM1 )
24498         dCAVdOM2  = dFdL * ( dFdOM2 )
24499         dCAVdOM12 = dFdL * ( dFdOM12 )
24500
24501         ertail(1) = xj*rij
24502         ertail(2) = yj*rij
24503         ertail(3) = zj*rij
24504        DO k = 1, 3
24505 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24506 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24507       pom = ertail(k)
24508 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24509       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24510               - (( dFdR + gg(k) ) * pom)/2.0
24511 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24512 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24513 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24514 !     &             - ( dFdR * pom )
24515       pom = ertail(k)
24516 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24517       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24518               + (( dFdR + gg(k) ) * pom)
24519 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24520 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24521 !c!     &             + ( dFdR * pom )
24522
24523       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24524               - (( dFdR + gg(k) ) * ertail(k))/2.0
24525 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24526
24527 !c!     &             - ( dFdR * ertail(k))
24528
24529       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24530               + (( dFdR + gg(k) ) * ertail(k))
24531 !c!     &             + ( dFdR * ertail(k))
24532
24533       gg(k) = 0.0d0
24534 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24535 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24536       END DO
24537
24538
24539        w1 = wdipdip_pepbase(1,itypj)
24540        w2 = -wdipdip_pepbase(3,itypj)/2.0
24541        w3 = wdipdip_pepbase(2,itypj)
24542 !       w1=0.0d0
24543 !       w2=0.0d0
24544 !c!-------------------------------------------------------------------
24545 !c! ECL
24546 !       w3=0.0d0
24547        fac = (om12 - 3.0d0 * om1 * om2)
24548        c1 = (w1 / (Rhead**3.0d0)) * fac
24549        c2 = (w2 / Rhead ** 6.0d0)  &
24550        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24551        c3= (w3/ Rhead ** 6.0d0)  &
24552        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24553
24554        ECL = c1 - c2 + c3
24555
24556        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24557        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24558        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24559        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24560        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24561
24562        dGCLdR = c1 - c2 + c3
24563 !c! dECL/dom1
24564        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24565        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24566        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24567        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24568        dGCLdOM1 = c1 - c2 + c3
24569 !c! dECL/dom2
24570        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24571        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24572        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24573        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24574
24575        dGCLdOM2 = c1 - c2 + c3
24576 !c! dECL/dom12
24577        c1 = w1 / (Rhead ** 3.0d0)
24578        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24579        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24580        dGCLdOM12 = c1 - c2 + c3
24581        DO k= 1, 3
24582       erhead(k) = Rhead_distance(k)/Rhead
24583        END DO
24584        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24585        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24586 !       facd1 = d1 * vbld_inv(i+nres)
24587 !       facd2 = d2 * vbld_inv(j+nres)
24588        DO k = 1, 3
24589
24590 !        pom = erhead(k)
24591 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24592 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24593 !                  - dGCLdR * pom
24594       pom = erhead(k)
24595 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24596       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24597               + dGCLdR * pom
24598
24599       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24600               - dGCLdR * erhead(k)/2.0d0
24601 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24602       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24603               - dGCLdR * erhead(k)/2.0d0
24604 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24605       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24606               + dGCLdR * erhead(k)
24607        END DO
24608 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24609        epepbase=epepbase+evdwij+Fcav+ECL
24610        call sc_grad_pepbase
24611        enddo
24612        enddo
24613       END SUBROUTINE epep_sc_base
24614       SUBROUTINE sc_grad_pepbase
24615       use calc_data
24616
24617        real (kind=8) :: dcosom1(3),dcosom2(3)
24618        eom1  =    &
24619             eps2der * eps2rt_om1   &
24620           - 2.0D0 * alf1 * eps3der &
24621           + sigder * sigsq_om1     &
24622           + dCAVdOM1               &
24623           + dGCLdOM1               &
24624           + dPOLdOM1
24625
24626        eom2  =  &
24627             eps2der * eps2rt_om2   &
24628           + 2.0D0 * alf2 * eps3der &
24629           + sigder * sigsq_om2     &
24630           + dCAVdOM2               &
24631           + dGCLdOM2               &
24632           + dPOLdOM2
24633
24634        eom12 =    &
24635             evdwij  * eps1_om12     &
24636           + eps2der * eps2rt_om12   &
24637           - 2.0D0 * alf12 * eps3der &
24638           + sigder *sigsq_om12      &
24639           + dCAVdOM12               &
24640           + dGCLdOM12
24641 !        om12=0.0
24642 !        eom12=0.0
24643 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24644 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24645 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24646 !                 *dsci_inv*2.0
24647 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24648 !               gg(1),gg(2),"rozne"
24649        DO k = 1, 3
24650       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24651       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24652       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24653       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24654              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24655              *dsci_inv*2.0 &
24656              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24657       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24658              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24659              *dsci_inv*2.0 &
24660              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24661 !         print *,eom12,eom2,om12,om2
24662 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24663 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24664       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24665              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24666              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24667       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24668        END DO
24669        RETURN
24670       END SUBROUTINE sc_grad_pepbase
24671       subroutine eprot_sc_phosphate(escpho)
24672       use calc_data
24673 !      implicit real*8 (a-h,o-z)
24674 !      include 'DIMENSIONS'
24675 !      include 'COMMON.GEO'
24676 !      include 'COMMON.VAR'
24677 !      include 'COMMON.LOCAL'
24678 !      include 'COMMON.CHAIN'
24679 !      include 'COMMON.DERIV'
24680 !      include 'COMMON.NAMES'
24681 !      include 'COMMON.INTERACT'
24682 !      include 'COMMON.IOUNITS'
24683 !      include 'COMMON.CALC'
24684 !      include 'COMMON.CONTROL'
24685 !      include 'COMMON.SBRIDGE'
24686       logical :: lprn
24687 !el local variables
24688       integer :: iint,itypi,itypi1,itypj,subchap
24689       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24690       real(kind=8) :: evdw,sig0ij,aa,bb
24691       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24692                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24693                 sslipi,sslipj,faclip,alpha_sco
24694       integer :: ii
24695       real(kind=8) :: fracinbuf
24696        real (kind=8) :: escpho
24697        real (kind=8),dimension(4):: ener
24698        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24699        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24700       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24701       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24702       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24703       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24704       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24705       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24706        real(kind=8),dimension(3,2)::chead,erhead_tail
24707        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24708        integer troll
24709        eps_out=80.0d0
24710        escpho=0.0d0
24711 !       do i=1,nres_molec(1)
24712       do i=ibond_start,ibond_end
24713       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24714       itypi  = itype(i,1)
24715       dxi    = dc_norm(1,nres+i)
24716       dyi    = dc_norm(2,nres+i)
24717       dzi    = dc_norm(3,nres+i)
24718       dsci_inv = vbld_inv(i+nres)
24719       xi=c(1,nres+i)
24720       yi=c(2,nres+i)
24721       zi=c(3,nres+i)
24722        call to_box(xi,yi,zi)
24723       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24724        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24725          itypj= itype(j,2)
24726          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24727           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24728          xj=(c(1,j)+c(1,j+1))/2.0
24729          yj=(c(2,j)+c(2,j+1))/2.0
24730          zj=(c(3,j)+c(3,j+1))/2.0
24731      call to_box(xj,yj,zj)
24732 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24733 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24734 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24735 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24736 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24737       xj=boxshift(xj-xi,boxxsize)
24738       yj=boxshift(yj-yi,boxysize)
24739       zj=boxshift(zj-zi,boxzsize)
24740           dxj = dc_norm( 1,j )
24741         dyj = dc_norm( 2,j )
24742         dzj = dc_norm( 3,j )
24743         dscj_inv = vbld_inv(j+1)
24744
24745 ! Gay-berne var's
24746         sig0ij = sigma_scpho(itypi )
24747         chi1   = chi_scpho(itypi,1 )
24748         chi2   = chi_scpho(itypi,2 )
24749 !          chi1=0.0d0
24750 !          chi2=0.0d0
24751         chi12  = chi1 * chi2
24752         chip1  = chipp_scpho(itypi,1 )
24753         chip2  = chipp_scpho(itypi,2 )
24754 !          chip1=0.0d0
24755 !          chip2=0.0d0
24756         chip12 = chip1 * chip2
24757         chis1 = chis_scpho(itypi,1)
24758         chis2 = chis_scpho(itypi,2)
24759         chis12 = chis1 * chis2
24760         sig1 = sigmap1_scpho(itypi)
24761         sig2 = sigmap2_scpho(itypi)
24762 !       write (*,*) "sig1 = ", sig1
24763 !       write (*,*) "sig1 = ", sig1
24764 !       write (*,*) "sig2 = ", sig2
24765 ! alpha factors from Fcav/Gcav
24766         alf1   = 0.0d0
24767         alf2   = 0.0d0
24768         alf12  = 0.0d0
24769         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24770
24771         b1 = alphasur_scpho(1,itypi)
24772 !          b1=0.0d0
24773         b2 = alphasur_scpho(2,itypi)
24774         b3 = alphasur_scpho(3,itypi)
24775         b4 = alphasur_scpho(4,itypi)
24776 ! used to determine whether we want to do quadrupole calculations
24777 ! used by Fgb
24778        eps_in = epsintab_scpho(itypi)
24779        if (eps_in.eq.0.0) eps_in=1.0
24780        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24781 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24782 !-------------------------------------------------------------------
24783 ! tail location and distance calculations
24784         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24785         d1j = 0.0
24786        DO k = 1,3
24787 ! location of polar head is computed by taking hydrophobic centre
24788 ! and moving by a d1 * dc_norm vector
24789 ! see unres publications for very informative images
24790       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24791       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24792 ! distance
24793 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24794 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24795       Rhead_distance(k) = chead(k,2) - chead(k,1)
24796        END DO
24797 ! pitagoras (root of sum of squares)
24798        Rhead = dsqrt( &
24799         (Rhead_distance(1)*Rhead_distance(1)) &
24800       + (Rhead_distance(2)*Rhead_distance(2)) &
24801       + (Rhead_distance(3)*Rhead_distance(3)))
24802        Rhead_sq=Rhead**2.0
24803 !-------------------------------------------------------------------
24804 ! zero everything that should be zero'ed
24805        evdwij = 0.0d0
24806        ECL = 0.0d0
24807        Elj = 0.0d0
24808        Equad = 0.0d0
24809        Epol = 0.0d0
24810        Fcav=0.0d0
24811        eheadtail = 0.0d0
24812        dGCLdR=0.0d0
24813        dGCLdOM1 = 0.0d0
24814        dGCLdOM2 = 0.0d0
24815        dGCLdOM12 = 0.0d0
24816        dPOLdOM1 = 0.0d0
24817        dPOLdOM2 = 0.0d0
24818         Fcav = 0.0d0
24819         dFdR = 0.0d0
24820         dCAVdOM1  = 0.0d0
24821         dCAVdOM2  = 0.0d0
24822         dCAVdOM12 = 0.0d0
24823         dscj_inv = vbld_inv(j+1)/2.0
24824 !dhead_scbasej(itypi,itypj)
24825 !          print *,i,j,dscj_inv,dsci_inv
24826 ! rij holds 1/(distance of Calpha atoms)
24827         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24828         rij  = dsqrt(rrij)
24829 !----------------------------
24830         CALL sc_angular
24831 ! this should be in elgrad_init but om's are calculated by sc_angular
24832 ! which in turn is used by older potentials
24833 ! om = omega, sqom = om^2
24834         sqom1  = om1 * om1
24835         sqom2  = om2 * om2
24836         sqom12 = om12 * om12
24837
24838 ! now we calculate EGB - Gey-Berne
24839 ! It will be summed up in evdwij and saved in evdw
24840         sigsq     = 1.0D0  / sigsq
24841         sig       = sig0ij * dsqrt(sigsq)
24842 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24843         rij_shift = 1.0/rij - sig + sig0ij
24844         IF (rij_shift.le.0.0D0) THEN
24845          evdw = 1.0D20
24846          RETURN
24847         END IF
24848         sigder = -sig * sigsq
24849         rij_shift = 1.0D0 / rij_shift
24850         fac       = rij_shift**expon
24851         c1        = fac  * fac * aa_scpho(itypi)
24852 !          c1        = 0.0d0
24853         c2        = fac  * bb_scpho(itypi)
24854 !          c2        = 0.0d0
24855         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24856         eps2der   = eps3rt * evdwij
24857         eps3der   = eps2rt * evdwij
24858 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24859         evdwij    = eps2rt * eps3rt * evdwij
24860         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24861         fac    = -expon * (c1 + evdwij) * rij_shift
24862         sigder = fac * sigder
24863 !          fac    = rij * fac
24864 ! Calculate distance derivative
24865         gg(1) =  fac
24866         gg(2) =  fac
24867         gg(3) =  fac
24868         fac = chis1 * sqom1 + chis2 * sqom2 &
24869         - 2.0d0 * chis12 * om1 * om2 * om12
24870 ! we will use pom later in Gcav, so dont mess with it!
24871         pom = 1.0d0 - chis1 * chis2 * sqom12
24872         Lambf = (1.0d0 - (fac / pom))
24873         Lambf = dsqrt(Lambf)
24874         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24875 !       write (*,*) "sparrow = ", sparrow
24876         Chif = 1.0d0/rij * sparrow
24877         ChiLambf = Chif * Lambf
24878         eagle = dsqrt(ChiLambf)
24879         bat = ChiLambf ** 11.0d0
24880         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24881         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24882         botsq = bot * bot
24883         Fcav = top / bot
24884         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24885         dbot = 12.0d0 * b4 * bat * Lambf
24886         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24887 !       dFdR = 0.0d0
24888 !      write (*,*) "dFcav/dR = ", dFdR
24889         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24890         dbot = 12.0d0 * b4 * bat * Chif
24891         eagle = Lambf * pom
24892         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24893         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24894         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24895             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24896
24897         dFdL = ((dtop * bot - top * dbot) / botsq)
24898 !       dFdL = 0.0d0
24899         dCAVdOM1  = dFdL * ( dFdOM1 )
24900         dCAVdOM2  = dFdL * ( dFdOM2 )
24901         dCAVdOM12 = dFdL * ( dFdOM12 )
24902
24903         ertail(1) = xj*rij
24904         ertail(2) = yj*rij
24905         ertail(3) = zj*rij
24906        DO k = 1, 3
24907 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24908 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24909 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24910
24911       pom = ertail(k)
24912 !        print *,pom,gg(k),dFdR
24913 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24914       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24915               - (( dFdR + gg(k) ) * pom)
24916 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24917 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24918 !     &             - ( dFdR * pom )
24919 !        pom = ertail(k)
24920 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24921 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24922 !                  + (( dFdR + gg(k) ) * pom)
24923 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24924 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24925 !c!     &             + ( dFdR * pom )
24926
24927       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24928               - (( dFdR + gg(k) ) * ertail(k))
24929 !c!     &             - ( dFdR * ertail(k))
24930
24931       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24932               + (( dFdR + gg(k) ) * ertail(k))/2.0
24933
24934       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24935               + (( dFdR + gg(k) ) * ertail(k))/2.0
24936
24937 !c!     &             + ( dFdR * ertail(k))
24938
24939       gg(k) = 0.0d0
24940       ENDDO
24941 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24942 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24943 !      alphapol1 = alphapol_scpho(itypi)
24944        if (wqq_scpho(itypi).ne.0.0) then
24945        Qij=wqq_scpho(itypi)/eps_in
24946        alpha_sco=1.d0/alphi_scpho(itypi)
24947 !       Qij=0.0
24948        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24949 !c! derivative of Ecl is Gcl...
24950        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24951             (Rhead*alpha_sco+1) ) / Rhead_sq
24952        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24953        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24954        w1        = wqdip_scpho(1,itypi)
24955        w2        = wqdip_scpho(2,itypi)
24956 !       w1=0.0d0
24957 !       w2=0.0d0
24958 !       pis       = sig0head_scbase(itypi,itypj)
24959 !       eps_head   = epshead_scbase(itypi,itypj)
24960 !c!-------------------------------------------------------------------
24961
24962 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24963 !c!     &        +dhead(1,1,itypi,itypj))**2))
24964 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24965 !c!     &        +dhead(2,1,itypi,itypj))**2))
24966
24967 !c!-------------------------------------------------------------------
24968 !c! ecl
24969        sparrow  = w1  *  om1
24970        hawk     = w2 *  (1.0d0 - sqom2)
24971        Ecl = sparrow / Rhead**2.0d0 &
24972          - hawk    / Rhead**4.0d0
24973 !c!-------------------------------------------------------------------
24974        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24975          1.0/rij,sparrow
24976
24977 !c! derivative of ecl is Gcl
24978 !c! dF/dr part
24979        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24980             + 4.0d0 * hawk    / Rhead**5.0d0
24981 !c! dF/dom1
24982        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24983 !c! dF/dom2
24984        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24985        endif
24986
24987 !c--------------------------------------------------------------------
24988 !c Polarization energy
24989 !c Epol
24990        R1 = 0.0d0
24991        DO k = 1, 3
24992 !c! Calculate head-to-tail distances tail is center of side-chain
24993       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24994        END DO
24995 !c! Pitagoras
24996        R1 = dsqrt(R1)
24997
24998       alphapol1 = alphapol_scpho(itypi)
24999 !      alphapol1=0.0
25000        MomoFac1 = (1.0d0 - chi2 * sqom1)
25001        RR1  = R1 * R1 / MomoFac1
25002        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25003 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25004        fgb1 = sqrt( RR1 + a12sq * ee1)
25005 !       eps_inout_fac=0.0d0
25006        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25007 ! derivative of Epol is Gpol...
25008        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25009             / (fgb1 ** 5.0d0)
25010        dFGBdR1 = ( (R1 / MomoFac1) &
25011            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25012            / ( 2.0d0 * fgb1 )
25013        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25014              * (2.0d0 - 0.5d0 * ee1) ) &
25015              / (2.0d0 * fgb1)
25016        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25017 !       dPOLdR1 = 0.0d0
25018 !       dPOLdOM1 = 0.0d0
25019        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25020              * (2.0d0 - 0.5d0 * ee1) ) &
25021              / (2.0d0 * fgb1)
25022
25023        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25024        dPOLdOM2 = 0.0
25025        DO k = 1, 3
25026       erhead(k) = Rhead_distance(k)/Rhead
25027       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25028        END DO
25029
25030        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25031        erdxj = scalar( erhead(1), dC_norm(1,j) )
25032        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25033 !       bat=0.0d0
25034        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25035        facd1 = d1i * vbld_inv(i+nres)
25036        facd2 = d1j * vbld_inv(j)
25037 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25038
25039        DO k = 1, 3
25040       hawk = (erhead_tail(k,1) + &
25041       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25042 !        facd1=0.0d0
25043 !        facd2=0.0d0
25044 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25045 !                pom,(erhead_tail(k,1))
25046
25047 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25048       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25049       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25050                - dGCLdR * pom &
25051                - dPOLdR1 *  (erhead_tail(k,1))
25052 !     &             - dGLJdR * pom
25053
25054       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25055 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25056 !                   + dGCLdR * pom  &
25057 !                   + dPOLdR1 * (erhead_tail(k,1))
25058 !     &             + dGLJdR * pom
25059
25060
25061       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25062               - dGCLdR * erhead(k) &
25063               - dPOLdR1 * erhead_tail(k,1)
25064 !     &             - dGLJdR * erhead(k)
25065
25066       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25067               + (dGCLdR * erhead(k)  &
25068               + dPOLdR1 * erhead_tail(k,1))/2.0
25069       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25070               + (dGCLdR * erhead(k)  &
25071               + dPOLdR1 * erhead_tail(k,1))/2.0
25072
25073 !     &             + dGLJdR * erhead(k)
25074 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25075
25076        END DO
25077 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25078        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25079       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25080        escpho=escpho+evdwij+epol+Fcav+ECL
25081        call sc_grad_scpho
25082        enddo
25083
25084       enddo
25085
25086       return
25087       end subroutine eprot_sc_phosphate
25088       SUBROUTINE sc_grad_scpho
25089       use calc_data
25090
25091        real (kind=8) :: dcosom1(3),dcosom2(3)
25092        eom1  =    &
25093             eps2der * eps2rt_om1   &
25094           - 2.0D0 * alf1 * eps3der &
25095           + sigder * sigsq_om1     &
25096           + dCAVdOM1               &
25097           + dGCLdOM1               &
25098           + dPOLdOM1
25099
25100        eom2  =  &
25101             eps2der * eps2rt_om2   &
25102           + 2.0D0 * alf2 * eps3der &
25103           + sigder * sigsq_om2     &
25104           + dCAVdOM2               &
25105           + dGCLdOM2               &
25106           + dPOLdOM2
25107
25108        eom12 =    &
25109             evdwij  * eps1_om12     &
25110           + eps2der * eps2rt_om12   &
25111           - 2.0D0 * alf12 * eps3der &
25112           + sigder *sigsq_om12      &
25113           + dCAVdOM12               &
25114           + dGCLdOM12
25115 !        om12=0.0
25116 !        eom12=0.0
25117 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25118 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25119 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25120 !                 *dsci_inv*2.0
25121 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25122 !               gg(1),gg(2),"rozne"
25123        DO k = 1, 3
25124       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25125       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25126       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25127       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25128              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25129              *dscj_inv*2.0 &
25130              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25131       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25132              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25133              *dscj_inv*2.0 &
25134              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25135       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25136              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25137              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25138
25139 !         print *,eom12,eom2,om12,om2
25140 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25141 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25142 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25143 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25144 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25145       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25146        END DO
25147        RETURN
25148       END SUBROUTINE sc_grad_scpho
25149       subroutine eprot_pep_phosphate(epeppho)
25150       use calc_data
25151 !      implicit real*8 (a-h,o-z)
25152 !      include 'DIMENSIONS'
25153 !      include 'COMMON.GEO'
25154 !      include 'COMMON.VAR'
25155 !      include 'COMMON.LOCAL'
25156 !      include 'COMMON.CHAIN'
25157 !      include 'COMMON.DERIV'
25158 !      include 'COMMON.NAMES'
25159 !      include 'COMMON.INTERACT'
25160 !      include 'COMMON.IOUNITS'
25161 !      include 'COMMON.CALC'
25162 !      include 'COMMON.CONTROL'
25163 !      include 'COMMON.SBRIDGE'
25164       logical :: lprn
25165 !el local variables
25166       integer :: iint,itypi,itypi1,itypj,subchap
25167       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25168       real(kind=8) :: evdw,sig0ij
25169       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25170                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25171                 sslipi,sslipj,faclip
25172       integer :: ii
25173       real(kind=8) :: fracinbuf
25174        real (kind=8) :: epeppho
25175        real (kind=8),dimension(4):: ener
25176        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25177        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25178       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25179       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25180       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25181       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25182       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25183       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25184        real(kind=8),dimension(3,2)::chead,erhead_tail
25185        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25186        integer troll
25187        real (kind=8) :: dcosom1(3),dcosom2(3)
25188        epeppho=0.0d0
25189 !       do i=1,nres_molec(1)
25190       do i=ibond_start,ibond_end
25191       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25192       itypi  = itype(i,1)
25193       dsci_inv = vbld_inv(i+1)/2.0
25194       dxi    = dc_norm(1,i)
25195       dyi    = dc_norm(2,i)
25196       dzi    = dc_norm(3,i)
25197       xi=(c(1,i)+c(1,i+1))/2.0
25198       yi=(c(2,i)+c(2,i+1))/2.0
25199       zi=(c(3,i)+c(3,i+1))/2.0
25200                call to_box(xi,yi,zi)
25201
25202         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25203          itypj= itype(j,2)
25204          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25205           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25206          xj=(c(1,j)+c(1,j+1))/2.0
25207          yj=(c(2,j)+c(2,j+1))/2.0
25208          zj=(c(3,j)+c(3,j+1))/2.0
25209                 call to_box(xj,yj,zj)
25210       xj=boxshift(xj-xi,boxxsize)
25211       yj=boxshift(yj-yi,boxysize)
25212       zj=boxshift(zj-zi,boxzsize)
25213
25214         dist_init=xj**2+yj**2+zj**2
25215         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25216         rij  = dsqrt(rrij)
25217         dxj = dc_norm( 1,j )
25218         dyj = dc_norm( 2,j )
25219         dzj = dc_norm( 3,j )
25220         dscj_inv = vbld_inv(j+1)/2.0
25221 ! Gay-berne var's
25222         sig0ij = sigma_peppho
25223 !          chi1=0.0d0
25224 !          chi2=0.0d0
25225         chi12  = chi1 * chi2
25226 !          chip1=0.0d0
25227 !          chip2=0.0d0
25228         chip12 = chip1 * chip2
25229 !          chis1 = 0.0d0
25230 !          chis2 = 0.0d0
25231         chis12 = chis1 * chis2
25232         sig1 = sigmap1_peppho
25233         sig2 = sigmap2_peppho
25234 !       write (*,*) "sig1 = ", sig1
25235 !       write (*,*) "sig1 = ", sig1
25236 !       write (*,*) "sig2 = ", sig2
25237 ! alpha factors from Fcav/Gcav
25238         alf1   = 0.0d0
25239         alf2   = 0.0d0
25240         alf12  = 0.0d0
25241         b1 = alphasur_peppho(1)
25242 !          b1=0.0d0
25243         b2 = alphasur_peppho(2)
25244         b3 = alphasur_peppho(3)
25245         b4 = alphasur_peppho(4)
25246         CALL sc_angular
25247        sqom1=om1*om1
25248        evdwij = 0.0d0
25249        ECL = 0.0d0
25250        Elj = 0.0d0
25251        Equad = 0.0d0
25252        Epol = 0.0d0
25253        Fcav=0.0d0
25254        eheadtail = 0.0d0
25255        dGCLdR=0.0d0
25256        dGCLdOM1 = 0.0d0
25257        dGCLdOM2 = 0.0d0
25258        dGCLdOM12 = 0.0d0
25259        dPOLdOM1 = 0.0d0
25260        dPOLdOM2 = 0.0d0
25261         Fcav = 0.0d0
25262         dFdR = 0.0d0
25263         dCAVdOM1  = 0.0d0
25264         dCAVdOM2  = 0.0d0
25265         dCAVdOM12 = 0.0d0
25266         rij_shift = rij
25267         fac       = rij_shift**expon
25268         c1        = fac  * fac * aa_peppho
25269 !          c1        = 0.0d0
25270         c2        = fac  * bb_peppho
25271 !          c2        = 0.0d0
25272         evdwij    =  c1 + c2
25273 ! Now cavity....................
25274        eagle = dsqrt(1.0/rij_shift)
25275        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25276         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25277         botsq = bot * bot
25278         Fcav = top / bot
25279         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25280         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25281         dFdR = ((dtop * bot - top * dbot) / botsq)
25282        w1        = wqdip_peppho(1)
25283        w2        = wqdip_peppho(2)
25284 !       w1=0.0d0
25285 !       w2=0.0d0
25286 !       pis       = sig0head_scbase(itypi,itypj)
25287 !       eps_head   = epshead_scbase(itypi,itypj)
25288 !c!-------------------------------------------------------------------
25289
25290 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25291 !c!     &        +dhead(1,1,itypi,itypj))**2))
25292 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25293 !c!     &        +dhead(2,1,itypi,itypj))**2))
25294
25295 !c!-------------------------------------------------------------------
25296 !c! ecl
25297        sparrow  = w1  *  om1
25298        hawk     = w2 *  (1.0d0 - sqom1)
25299        Ecl = sparrow * rij_shift**2.0d0 &
25300          - hawk    * rij_shift**4.0d0
25301 !c!-------------------------------------------------------------------
25302 !c! derivative of ecl is Gcl
25303 !c! dF/dr part
25304 !       rij_shift=5.0
25305        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25306             + 4.0d0 * hawk    * rij_shift**5.0d0
25307 !c! dF/dom1
25308        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25309 !c! dF/dom2
25310        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25311        eom1  =    dGCLdOM1+dGCLdOM2
25312        eom2  =    0.0
25313
25314         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25315 !          fac=0.0
25316         gg(1) =  fac*xj*rij
25317         gg(2) =  fac*yj*rij
25318         gg(3) =  fac*zj*rij
25319        do k=1,3
25320        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25321        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25322        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25323        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25324        gg(k)=0.0
25325        enddo
25326
25327       DO k = 1, 3
25328       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25329       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25330       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25331       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25332 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25333       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25334 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25335       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25336              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25337       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25338              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25339       enddo
25340        epeppho=epeppho+evdwij+Fcav+ECL
25341 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25342        enddo
25343        enddo
25344       end subroutine eprot_pep_phosphate
25345 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25346       subroutine emomo(evdw)
25347       use calc_data
25348       use comm_momo
25349 !      implicit real*8 (a-h,o-z)
25350 !      include 'DIMENSIONS'
25351 !      include 'COMMON.GEO'
25352 !      include 'COMMON.VAR'
25353 !      include 'COMMON.LOCAL'
25354 !      include 'COMMON.CHAIN'
25355 !      include 'COMMON.DERIV'
25356 !      include 'COMMON.NAMES'
25357 !      include 'COMMON.INTERACT'
25358 !      include 'COMMON.IOUNITS'
25359 !      include 'COMMON.CALC'
25360 !      include 'COMMON.CONTROL'
25361 !      include 'COMMON.SBRIDGE'
25362       logical :: lprn
25363 !el local variables
25364       integer :: iint,itypi1,subchap,isel
25365       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25366       real(kind=8) :: evdw,aa,bb
25367       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25368                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25369                 sslipi,sslipj,faclip,alpha_sco
25370       integer :: ii
25371       real(kind=8) :: fracinbuf
25372        real (kind=8) :: escpho
25373        real (kind=8),dimension(4):: ener
25374        real(kind=8) :: b1,b2,egb
25375        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25376       Lambf,&
25377       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25378       dFdOM2,dFdL,dFdOM12,&
25379       federmaus,&
25380       d1i,d1j
25381 !       real(kind=8),dimension(3,2)::erhead_tail
25382 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25383        real(kind=8) ::  facd4, adler, Fgb, facd3
25384        integer troll,jj,istate
25385        real (kind=8) :: dcosom1(3),dcosom2(3)
25386        evdw=0.0d0
25387        eps_out=80.0d0
25388        sss_ele_cut=1.0d0
25389 !       print *,"EVDW KURW",evdw,nres
25390       do i=iatsc_s,iatsc_e
25391 !        print *,"I am in EVDW",i
25392       itypi=iabs(itype(i,1))
25393 !        if (i.ne.47) cycle
25394       if (itypi.eq.ntyp1) cycle
25395       itypi1=iabs(itype(i+1,1))
25396       xi=c(1,nres+i)
25397       yi=c(2,nres+i)
25398       zi=c(3,nres+i)
25399         call to_box(xi,yi,zi)
25400         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25401 !       endif
25402 !       print *, sslipi,ssgradlipi
25403       dxi=dc_norm(1,nres+i)
25404       dyi=dc_norm(2,nres+i)
25405       dzi=dc_norm(3,nres+i)
25406 !        dsci_inv=dsc_inv(itypi)
25407       dsci_inv=vbld_inv(i+nres)
25408 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25409 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25410 !
25411 ! Calculate SC interaction energy.
25412 !
25413       do iint=1,nint_gr(i)
25414         do j=istart(i,iint),iend(i,iint)
25415 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25416           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25417             call dyn_ssbond_ene(i,j,evdwij)
25418             evdw=evdw+evdwij
25419             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25420                         'evdw',i,j,evdwij,' ss'
25421 !              if (energy_dec) write (iout,*) &
25422 !                              'evdw',i,j,evdwij,' ss'
25423            do k=j+1,iend(i,iint)
25424 !C search over all next residues
25425             if (dyn_ss_mask(k)) then
25426 !C check if they are cysteins
25427 !C              write(iout,*) 'k=',k
25428
25429 !c              write(iout,*) "PRZED TRI", evdwij
25430 !               evdwij_przed_tri=evdwij
25431             call triple_ssbond_ene(i,j,k,evdwij)
25432 !c               if(evdwij_przed_tri.ne.evdwij) then
25433 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25434 !c               endif
25435
25436 !c              write(iout,*) "PO TRI", evdwij
25437 !C call the energy function that removes the artifical triple disulfide
25438 !C bond the soubroutine is located in ssMD.F
25439             evdw=evdw+evdwij
25440             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25441                       'evdw',i,j,evdwij,'tss'
25442             endif!dyn_ss_mask(k)
25443            enddo! k
25444           ELSE
25445 !el            ind=ind+1
25446           itypj=iabs(itype(j,1))
25447           if (itypj.eq.ntyp1) cycle
25448            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25449
25450 !             if (j.ne.78) cycle
25451 !            dscj_inv=dsc_inv(itypj)
25452           dscj_inv=vbld_inv(j+nres)
25453          xj=c(1,j+nres)
25454          yj=c(2,j+nres)
25455          zj=c(3,j+nres)
25456      call to_box(xj,yj,zj)
25457      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25458 !      write(iout,*) "KRUWA", i,j
25459       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25460       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25461       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25462       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25463       xj=boxshift(xj-xi,boxxsize)
25464       yj=boxshift(yj-yi,boxysize)
25465       zj=boxshift(zj-zi,boxzsize)
25466         dxj = dc_norm( 1, nres+j )
25467         dyj = dc_norm( 2, nres+j )
25468         dzj = dc_norm( 3, nres+j )
25469 !          print *,i,j,itypi,itypj
25470 !          d1i=0.0d0
25471 !          d1j=0.0d0
25472 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25473 ! Gay-berne var's
25474 !1!          sig0ij = sigma_scsc( itypi,itypj )
25475 !          chi1=0.0d0
25476 !          chi2=0.0d0
25477 !          chip1=0.0d0
25478 !          chip2=0.0d0
25479 ! not used by momo potential, but needed by sc_angular which is shared
25480 ! by all energy_potential subroutines
25481         alf1   = 0.0d0
25482         alf2   = 0.0d0
25483         alf12  = 0.0d0
25484         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25485 !       a12sq = a12sq * a12sq
25486 ! charge of amino acid itypi is...
25487         chis1 = chis(itypi,itypj)
25488         chis2 = chis(itypj,itypi)
25489         chis12 = chis1 * chis2
25490         sig1 = sigmap1(itypi,itypj)
25491         sig2 = sigmap2(itypi,itypj)
25492 !       write (*,*) "sig1 = ", sig1
25493 !          chis1=0.0
25494 !          chis2=0.0
25495 !                    chis12 = chis1 * chis2
25496 !          sig1=0.0
25497 !          sig2=0.0
25498 !       write (*,*) "sig2 = ", sig2
25499 ! alpha factors from Fcav/Gcav
25500         b1cav = alphasur(1,itypi,itypj)
25501 !          b1cav=0.0d0
25502         b2cav = alphasur(2,itypi,itypj)
25503         b3cav = alphasur(3,itypi,itypj)
25504         b4cav = alphasur(4,itypi,itypj)
25505 ! used to determine whether we want to do quadrupole calculations
25506        eps_in = epsintab(itypi,itypj)
25507        if (eps_in.eq.0.0) eps_in=1.0
25508
25509        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25510        Rtail = 0.0d0
25511 !       dtail(1,itypi,itypj)=0.0
25512 !       dtail(2,itypi,itypj)=0.0
25513
25514        DO k = 1, 3
25515       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25516       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25517        END DO
25518 !c! tail distances will be themselves usefull elswhere
25519 !c1 (in Gcav, for example)
25520        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25521        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25522        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25523        Rtail = dsqrt( &
25524         (Rtail_distance(1)*Rtail_distance(1)) &
25525       + (Rtail_distance(2)*Rtail_distance(2)) &
25526       + (Rtail_distance(3)*Rtail_distance(3)))
25527
25528 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25529 !-------------------------------------------------------------------
25530 ! tail location and distance calculations
25531        d1 = dhead(1, 1, itypi, itypj)
25532        d2 = dhead(2, 1, itypi, itypj)
25533
25534        DO k = 1,3
25535 ! location of polar head is computed by taking hydrophobic centre
25536 ! and moving by a d1 * dc_norm vector
25537 ! see unres publications for very informative images
25538       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25539       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25540 ! distance
25541 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25542 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25543       Rhead_distance(k) = chead(k,2) - chead(k,1)
25544        END DO
25545 ! pitagoras (root of sum of squares)
25546        Rhead = dsqrt( &
25547         (Rhead_distance(1)*Rhead_distance(1)) &
25548       + (Rhead_distance(2)*Rhead_distance(2)) &
25549       + (Rhead_distance(3)*Rhead_distance(3)))
25550 !-------------------------------------------------------------------
25551 ! zero everything that should be zero'ed
25552        evdwij = 0.0d0
25553        ECL = 0.0d0
25554        Elj = 0.0d0
25555        Equad = 0.0d0
25556        Epol = 0.0d0
25557        Fcav=0.0d0
25558        eheadtail = 0.0d0
25559        dGCLdOM1 = 0.0d0
25560        dGCLdOM2 = 0.0d0
25561        dGCLdOM12 = 0.0d0
25562        dPOLdOM1 = 0.0d0
25563        dPOLdOM2 = 0.0d0
25564         Fcav = 0.0d0
25565         dFdR = 0.0d0
25566         dCAVdOM1  = 0.0d0
25567         dCAVdOM2  = 0.0d0
25568         dCAVdOM12 = 0.0d0
25569         dscj_inv = vbld_inv(j+nres)
25570 !          print *,i,j,dscj_inv,dsci_inv
25571 ! rij holds 1/(distance of Calpha atoms)
25572         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25573         rij  = dsqrt(rrij)
25574 !----------------------------
25575         CALL sc_angular
25576 ! this should be in elgrad_init but om's are calculated by sc_angular
25577 ! which in turn is used by older potentials
25578 ! om = omega, sqom = om^2
25579         sqom1  = om1 * om1
25580         sqom2  = om2 * om2
25581         sqom12 = om12 * om12
25582
25583 ! now we calculate EGB - Gey-Berne
25584 ! It will be summed up in evdwij and saved in evdw
25585         sigsq     = 1.0D0  / sigsq
25586         sig       = sig0ij * dsqrt(sigsq)
25587 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25588         rij_shift = Rtail - sig + sig0ij
25589         IF (rij_shift.le.0.0D0) THEN
25590          evdw = 1.0D20
25591          RETURN
25592         END IF
25593         sigder = -sig * sigsq
25594         rij_shift = 1.0D0 / rij_shift
25595         fac       = rij_shift**expon
25596         c1        = fac  * fac * aa_aq(itypi,itypj)
25597 !          print *,"ADAM",aa_aq(itypi,itypj)
25598
25599 !          c1        = 0.0d0
25600         c2        = fac  * bb_aq(itypi,itypj)
25601 !          c2        = 0.0d0
25602         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25603         eps2der   = eps3rt * evdwij
25604         eps3der   = eps2rt * evdwij
25605 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25606         evdwij    = eps2rt * eps3rt * evdwij
25607 !#ifdef TSCSC
25608 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25609 !           evdw_p = evdw_p + evdwij
25610 !          ELSE
25611 !           evdw_m = evdw_m + evdwij
25612 !          END IF
25613 !#else
25614         evdw = evdw  &
25615             + evdwij
25616 !#endif
25617
25618         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25619         fac    = -expon * (c1 + evdwij) * rij_shift
25620         sigder = fac * sigder
25621 !          fac    = rij * fac
25622 ! Calculate distance derivative
25623         gg(1) =  fac
25624         gg(2) =  fac
25625         gg(3) =  fac
25626 !          if (b2.gt.0.0) then
25627         fac = chis1 * sqom1 + chis2 * sqom2 &
25628         - 2.0d0 * chis12 * om1 * om2 * om12
25629 ! we will use pom later in Gcav, so dont mess with it!
25630         pom = 1.0d0 - chis1 * chis2 * sqom12
25631         Lambf = (1.0d0 - (fac / pom))
25632 !          print *,"fac,pom",fac,pom,Lambf
25633         Lambf = dsqrt(Lambf)
25634         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25635 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25636 !       write (*,*) "sparrow = ", sparrow
25637         Chif = Rtail * sparrow
25638 !           print *,"rij,sparrow",rij , sparrow
25639         ChiLambf = Chif * Lambf
25640         eagle = dsqrt(ChiLambf)
25641         bat = ChiLambf ** 11.0d0
25642         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25643         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25644         botsq = bot * bot
25645 !          print *,top,bot,"bot,top",ChiLambf,Chif
25646         Fcav = top / bot
25647
25648        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25649        dbot = 12.0d0 * b4cav * bat * Lambf
25650        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25651
25652         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25653         dbot = 12.0d0 * b4cav * bat * Chif
25654         eagle = Lambf * pom
25655         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25656         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25657         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25658             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25659
25660         dFdL = ((dtop * bot - top * dbot) / botsq)
25661 !       dFdL = 0.0d0
25662         dCAVdOM1  = dFdL * ( dFdOM1 )
25663         dCAVdOM2  = dFdL * ( dFdOM2 )
25664         dCAVdOM12 = dFdL * ( dFdOM12 )
25665
25666        DO k= 1, 3
25667       ertail(k) = Rtail_distance(k)/Rtail
25668        END DO
25669        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25670        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25671        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25672        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25673        DO k = 1, 3
25674 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25675 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25676       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25677       gvdwx(k,i) = gvdwx(k,i) &
25678               - (( dFdR + gg(k) ) * pom)
25679 !c!     &             - ( dFdR * pom )
25680       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25681       gvdwx(k,j) = gvdwx(k,j)   &
25682               + (( dFdR + gg(k) ) * pom)
25683 !c!     &             + ( dFdR * pom )
25684
25685       gvdwc(k,i) = gvdwc(k,i)  &
25686               - (( dFdR + gg(k) ) * ertail(k))
25687 !c!     &             - ( dFdR * ertail(k))
25688
25689       gvdwc(k,j) = gvdwc(k,j) &
25690               + (( dFdR + gg(k) ) * ertail(k))
25691 !c!     &             + ( dFdR * ertail(k))
25692
25693       gg(k) = 0.0d0
25694 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25695 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25696       END DO
25697
25698
25699 !c! Compute head-head and head-tail energies for each state
25700
25701         isel = iabs(Qi) + iabs(Qj)
25702 ! double charge for Phophorylated! itype - 25,27,27
25703 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25704 !            Qi=Qi*2
25705 !            Qij=Qij*2
25706 !           endif
25707 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25708 !            Qj=Qj*2
25709 !            Qij=Qij*2
25710 !           endif
25711
25712 !          isel=0
25713         IF (isel.eq.0) THEN
25714 !c! No charges - do nothing
25715          eheadtail = 0.0d0
25716
25717         ELSE IF (isel.eq.4) THEN
25718 !c! Calculate dipole-dipole interactions
25719          CALL edd(ecl)
25720          eheadtail = ECL
25721 !           eheadtail = 0.0d0
25722
25723         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25724 !c! Charge-nonpolar interactions
25725         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25726           Qi=Qi*2
25727           Qij=Qij*2
25728          endif
25729         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25730           Qj=Qj*2
25731           Qij=Qij*2
25732          endif
25733
25734          CALL eqn(epol)
25735          eheadtail = epol
25736 !           eheadtail = 0.0d0
25737
25738         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25739 !c! Nonpolar-charge interactions
25740         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25741           Qi=Qi*2
25742           Qij=Qij*2
25743          endif
25744         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25745           Qj=Qj*2
25746           Qij=Qij*2
25747          endif
25748
25749          CALL enq(epol)
25750          eheadtail = epol
25751 !           eheadtail = 0.0d0
25752
25753         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25754 !c! Charge-dipole interactions
25755         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25756           Qi=Qi*2
25757           Qij=Qij*2
25758          endif
25759         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25760           Qj=Qj*2
25761           Qij=Qij*2
25762          endif
25763
25764          CALL eqd(ecl, elj, epol)
25765          eheadtail = ECL + elj + epol
25766 !           eheadtail = 0.0d0
25767
25768         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25769 !c! Dipole-charge interactions
25770         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25771           Qi=Qi*2
25772           Qij=Qij*2
25773          endif
25774         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25775           Qj=Qj*2
25776           Qij=Qij*2
25777          endif
25778          CALL edq(ecl, elj, epol)
25779         eheadtail = ECL + elj + epol
25780 !           eheadtail = 0.0d0
25781
25782         ELSE IF ((isel.eq.2.and.   &
25783              iabs(Qi).eq.1).and.  &
25784              nstate(itypi,itypj).eq.1) THEN
25785 !c! Same charge-charge interaction ( +/+ or -/- )
25786         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25787           Qi=Qi*2
25788           Qij=Qij*2
25789          endif
25790         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25791           Qj=Qj*2
25792           Qij=Qij*2
25793          endif
25794
25795          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25796          eheadtail = ECL + Egb + Epol + Fisocav + Elj
25797 !           eheadtail = 0.0d0
25798
25799         ELSE IF ((isel.eq.2.and.  &
25800              iabs(Qi).eq.1).and. &
25801              nstate(itypi,itypj).ne.1) THEN
25802 !c! Different charge-charge interaction ( +/- or -/+ )
25803         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25804           Qi=Qi*2
25805           Qij=Qij*2
25806          endif
25807         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25808           Qj=Qj*2
25809           Qij=Qij*2
25810          endif
25811
25812          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25813         END IF
25814        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25815       evdw = evdw  + Fcav + eheadtail
25816
25817        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25818       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25819       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25820       Equad,evdwij+Fcav+eheadtail,evdw
25821 !       evdw = evdw  + Fcav  + eheadtail
25822
25823       iF (nstate(itypi,itypj).eq.1) THEN
25824       CALL sc_grad
25825        END IF
25826 !c!-------------------------------------------------------------------
25827 !c! NAPISY KONCOWE
25828        END DO   ! j
25829       END DO    ! iint
25830        END DO     ! i
25831 !c      write (iout,*) "Number of loop steps in EGB:",ind
25832 !c      energy_dec=.false.
25833 !              print *,"EVDW KURW",evdw,nres
25834
25835        RETURN
25836       END SUBROUTINE emomo
25837 !C------------------------------------------------------------------------------------
25838       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25839       use calc_data
25840       use comm_momo
25841        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25842        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25843 !       integer :: k
25844 !c! Epol and Gpol analytical parameters
25845        alphapol1 = alphapol(itypi,itypj)
25846        alphapol2 = alphapol(itypj,itypi)
25847 !c! Fisocav and Gisocav analytical parameters
25848        al1  = alphiso(1,itypi,itypj)
25849        al2  = alphiso(2,itypi,itypj)
25850        al3  = alphiso(3,itypi,itypj)
25851        al4  = alphiso(4,itypi,itypj)
25852        csig = (1.0d0  &
25853          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25854          + sigiso2(itypi,itypj)**2.0d0))
25855 !c!
25856        pis  = sig0head(itypi,itypj)
25857        eps_head = epshead(itypi,itypj)
25858        Rhead_sq = Rhead * Rhead
25859 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25860 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25861        R1 = 0.0d0
25862        R2 = 0.0d0
25863        DO k = 1, 3
25864 !c! Calculate head-to-tail distances needed by Epol
25865       R1=R1+(ctail(k,2)-chead(k,1))**2
25866       R2=R2+(chead(k,2)-ctail(k,1))**2
25867        END DO
25868 !c! Pitagoras
25869        R1 = dsqrt(R1)
25870        R2 = dsqrt(R2)
25871
25872 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25873 !c!     &        +dhead(1,1,itypi,itypj))**2))
25874 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25875 !c!     &        +dhead(2,1,itypi,itypj))**2))
25876
25877 !c!-------------------------------------------------------------------
25878 !c! Coulomb electrostatic interaction
25879        Ecl = (332.0d0 * Qij) / Rhead
25880 !c! derivative of Ecl is Gcl...
25881        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25882        dGCLdOM1 = 0.0d0
25883        dGCLdOM2 = 0.0d0
25884        dGCLdOM12 = 0.0d0
25885        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25886        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25887        debkap=debaykap(itypi,itypj)
25888        Egb = -(332.0d0 * Qij *&
25889       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25890 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25891 !c! Derivative of Egb is Ggb...
25892        dGGBdFGB = -(-332.0d0 * Qij * &
25893        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25894        -(332.0d0 * Qij *&
25895       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25896        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25897        dGGBdR = dGGBdFGB * dFGBdR
25898 !c!-------------------------------------------------------------------
25899 !c! Fisocav - isotropic cavity creation term
25900 !c! or "how much energy it costs to put charged head in water"
25901        pom = Rhead * csig
25902        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25903        bot = (1.0d0 + al4 * pom**12.0d0)
25904        botsq = bot * bot
25905        FisoCav = top / bot
25906 !      write (*,*) "Rhead = ",Rhead
25907 !      write (*,*) "csig = ",csig
25908 !      write (*,*) "pom = ",pom
25909 !      write (*,*) "al1 = ",al1
25910 !      write (*,*) "al2 = ",al2
25911 !      write (*,*) "al3 = ",al3
25912 !      write (*,*) "al4 = ",al4
25913 !        write (*,*) "top = ",top
25914 !        write (*,*) "bot = ",bot
25915 !c! Derivative of Fisocav is GCV...
25916        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25917        dbot = 12.0d0 * al4 * pom ** 11.0d0
25918        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25919 !c!-------------------------------------------------------------------
25920 !c! Epol
25921 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25922        MomoFac1 = (1.0d0 - chi1 * sqom2)
25923        MomoFac2 = (1.0d0 - chi2 * sqom1)
25924        RR1  = ( R1 * R1 ) / MomoFac1
25925        RR2  = ( R2 * R2 ) / MomoFac2
25926        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25927        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25928        fgb1 = sqrt( RR1 + a12sq * ee1 )
25929        fgb2 = sqrt( RR2 + a12sq * ee2 )
25930        epol = 332.0d0 * eps_inout_fac * ( &
25931       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25932 !c!       epol = 0.0d0
25933        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25934              / (fgb1 ** 5.0d0)
25935        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25936              / (fgb2 ** 5.0d0)
25937        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25938            / ( 2.0d0 * fgb1 )
25939        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25940            / ( 2.0d0 * fgb2 )
25941        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25942             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25943        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25944             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25945        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25946 !c!       dPOLdR1 = 0.0d0
25947        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25948 !c!       dPOLdR2 = 0.0d0
25949        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25950 !c!       dPOLdOM1 = 0.0d0
25951        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25952 !c!       dPOLdOM2 = 0.0d0
25953 !c!-------------------------------------------------------------------
25954 !c! Elj
25955 !c! Lennard-Jones 6-12 interaction between heads
25956        pom = (pis / Rhead)**6.0d0
25957        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25958 !c! derivative of Elj is Glj
25959        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25960            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25961 !c!-------------------------------------------------------------------
25962 !c! Return the results
25963 !c! These things do the dRdX derivatives, that is
25964 !c! allow us to change what we see from function that changes with
25965 !c! distance to function that changes with LOCATION (of the interaction
25966 !c! site)
25967        DO k = 1, 3
25968       erhead(k) = Rhead_distance(k)/Rhead
25969       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25970       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25971        END DO
25972
25973        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25974        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25975        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25976        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25977        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25978        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25979        facd1 = d1 * vbld_inv(i+nres)
25980        facd2 = d2 * vbld_inv(j+nres)
25981        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25982        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25983
25984 !c! Now we add appropriate partial derivatives (one in each dimension)
25985        DO k = 1, 3
25986       hawk   = (erhead_tail(k,1) + &
25987       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25988       condor = (erhead_tail(k,2) + &
25989       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25990
25991       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25992       gvdwx(k,i) = gvdwx(k,i) &
25993               - dGCLdR * pom&
25994               - dGGBdR * pom&
25995               - dGCVdR * pom&
25996               - dPOLdR1 * hawk&
25997               - dPOLdR2 * (erhead_tail(k,2)&
25998       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25999               - dGLJdR * pom
26000
26001       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26002       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26003                + dGGBdR * pom+ dGCVdR * pom&
26004               + dPOLdR1 * (erhead_tail(k,1)&
26005       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26006               + dPOLdR2 * condor + dGLJdR * pom
26007
26008       gvdwc(k,i) = gvdwc(k,i)  &
26009               - dGCLdR * erhead(k)&
26010               - dGGBdR * erhead(k)&
26011               - dGCVdR * erhead(k)&
26012               - dPOLdR1 * erhead_tail(k,1)&
26013               - dPOLdR2 * erhead_tail(k,2)&
26014               - dGLJdR * erhead(k)
26015
26016       gvdwc(k,j) = gvdwc(k,j)         &
26017               + dGCLdR * erhead(k) &
26018               + dGGBdR * erhead(k) &
26019               + dGCVdR * erhead(k) &
26020               + dPOLdR1 * erhead_tail(k,1) &
26021               + dPOLdR2 * erhead_tail(k,2)&
26022               + dGLJdR * erhead(k)
26023
26024        END DO
26025        RETURN
26026       END SUBROUTINE eqq
26027
26028       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26029       use calc_data
26030       use comm_momo
26031        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26032        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26033 !       integer :: k
26034 !c! Epol and Gpol analytical parameters
26035        alphapol1 = alphapolcat(itypi,itypj)
26036        alphapol2 = alphapolcat2(itypj,itypi)
26037 !c! Fisocav and Gisocav analytical parameters
26038        al1  = alphisocat(1,itypi,itypj)
26039        al2  = alphisocat(2,itypi,itypj)
26040        al3  = alphisocat(3,itypi,itypj)
26041        al4  = alphisocat(4,itypi,itypj)
26042        csig = (1.0d0  &
26043          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26044          + sigiso2cat(itypi,itypj)**2.0d0))
26045 !c!
26046        pis  = sig0headcat(itypi,itypj)
26047        eps_head = epsheadcat(itypi,itypj)
26048        Rhead_sq = Rhead * Rhead
26049 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26050 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26051        R1 = 0.0d0
26052        R2 = 0.0d0
26053        DO k = 1, 3
26054 !c! Calculate head-to-tail distances needed by Epol
26055       R1=R1+(ctail(k,2)-chead(k,1))**2
26056       R2=R2+(chead(k,2)-ctail(k,1))**2
26057        END DO
26058 !c! Pitagoras
26059        R1 = dsqrt(R1)
26060        R2 = dsqrt(R2)
26061
26062 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26063 !c!     &        +dhead(1,1,itypi,itypj))**2))
26064 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26065 !c!     &        +dhead(2,1,itypi,itypj))**2))
26066
26067 !c!-------------------------------------------------------------------
26068 !c! Coulomb electrostatic interaction
26069        Ecl = (332.0d0 * Qij) / Rhead
26070 !c! derivative of Ecl is Gcl...
26071        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26072        dGCLdOM1 = 0.0d0
26073        dGCLdOM2 = 0.0d0
26074        dGCLdOM12 = 0.0d0
26075        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26076        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26077        debkap=debaykapcat(itypi,itypj)
26078        Egb = -(332.0d0 * Qij *&
26079       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26080 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26081 !c! Derivative of Egb is Ggb...
26082        dGGBdFGB = -(-332.0d0 * Qij * &
26083        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26084        -(332.0d0 * Qij *&
26085       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26086        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26087        dGGBdR = dGGBdFGB * dFGBdR
26088 !c!-------------------------------------------------------------------
26089 !c! Fisocav - isotropic cavity creation term
26090 !c! or "how much energy it costs to put charged head in water"
26091        pom = Rhead * csig
26092        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26093        bot = (1.0d0 + al4 * pom**12.0d0)
26094        botsq = bot * bot
26095        FisoCav = top / bot
26096 !      write (*,*) "Rhead = ",Rhead
26097 !      write (*,*) "csig = ",csig
26098 !      write (*,*) "pom = ",pom
26099 !      write (*,*) "al1 = ",al1
26100 !      write (*,*) "al2 = ",al2
26101 !      write (*,*) "al3 = ",al3
26102 !      write (*,*) "al4 = ",al4
26103 !        write (*,*) "top = ",top
26104 !        write (*,*) "bot = ",bot
26105 !c! Derivative of Fisocav is GCV...
26106        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26107        dbot = 12.0d0 * al4 * pom ** 11.0d0
26108        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26109 !c!-------------------------------------------------------------------
26110 !c! Epol
26111 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26112        MomoFac1 = (1.0d0 - chi1 * sqom2)
26113        MomoFac2 = (1.0d0 - chi2 * sqom1)
26114        RR1  = ( R1 * R1 ) / MomoFac1
26115        RR2  = ( R2 * R2 ) / MomoFac2
26116        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26117        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26118        fgb1 = sqrt( RR1 + a12sq * ee1 )
26119        fgb2 = sqrt( RR2 + a12sq * ee2 )
26120        epol = 332.0d0 * eps_inout_fac * ( &
26121       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26122 !c!       epol = 0.0d0
26123        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26124              / (fgb1 ** 5.0d0)
26125        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26126              / (fgb2 ** 5.0d0)
26127        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26128            / ( 2.0d0 * fgb1 )
26129        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26130            / ( 2.0d0 * fgb2 )
26131        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26132             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26133        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26134             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26135        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26136 !c!       dPOLdR1 = 0.0d0
26137        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26138 !c!       dPOLdR2 = 0.0d0
26139        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26140 !c!       dPOLdOM1 = 0.0d0
26141        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26142 !c!       dPOLdOM2 = 0.0d0
26143 !c!-------------------------------------------------------------------
26144 !c! Elj
26145 !c! Lennard-Jones 6-12 interaction between heads
26146        pom = (pis / Rhead)**6.0d0
26147        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26148 !c! derivative of Elj is Glj
26149        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26150            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26151 !c!-------------------------------------------------------------------
26152 !c! Return the results
26153 !c! These things do the dRdX derivatives, that is
26154 !c! allow us to change what we see from function that changes with
26155 !c! distance to function that changes with LOCATION (of the interaction
26156 !c! site)
26157        DO k = 1, 3
26158       erhead(k) = Rhead_distance(k)/Rhead
26159       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26160       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26161        END DO
26162
26163        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26164        erdxj = scalar( erhead(1), dC_norm(1,j) )
26165        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26166        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26167        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26168        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26169        facd1 = d1 * vbld_inv(i+nres)
26170        facd2 = d2 * vbld_inv(j)
26171        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26172        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26173
26174 !c! Now we add appropriate partial derivatives (one in each dimension)
26175        DO k = 1, 3
26176       hawk   = (erhead_tail(k,1) + &
26177       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26178       condor = (erhead_tail(k,2) + &
26179       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26180
26181       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26182       gradpepcatx(k,i) = gradpepcatx(k,i) &
26183               - dGCLdR * pom&
26184               - dGGBdR * pom&
26185               - dGCVdR * pom&
26186               - dPOLdR1 * hawk&
26187               - dPOLdR2 * (erhead_tail(k,2)&
26188       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26189               - dGLJdR * pom
26190
26191       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26192 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26193 !                   + dGGBdR * pom+ dGCVdR * pom&
26194 !                  + dPOLdR1 * (erhead_tail(k,1)&
26195 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26196 !                  + dPOLdR2 * condor + dGLJdR * pom
26197
26198       gradpepcat(k,i) = gradpepcat(k,i)  &
26199               - dGCLdR * erhead(k)&
26200               - dGGBdR * erhead(k)&
26201               - dGCVdR * erhead(k)&
26202               - dPOLdR1 * erhead_tail(k,1)&
26203               - dPOLdR2 * erhead_tail(k,2)&
26204               - dGLJdR * erhead(k)
26205
26206       gradpepcat(k,j) = gradpepcat(k,j)         &
26207               + dGCLdR * erhead(k) &
26208               + dGGBdR * erhead(k) &
26209               + dGCVdR * erhead(k) &
26210               + dPOLdR1 * erhead_tail(k,1) &
26211               + dPOLdR2 * erhead_tail(k,2)&
26212               + dGLJdR * erhead(k)
26213
26214        END DO
26215        RETURN
26216       END SUBROUTINE eqq_cat
26217 !c!-------------------------------------------------------------------
26218       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26219       use comm_momo
26220       use calc_data
26221
26222        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26223        double precision ener(4)
26224        double precision dcosom1(3),dcosom2(3)
26225 !c! used in Epol derivatives
26226        double precision facd3, facd4
26227        double precision federmaus, adler
26228        integer istate,ii,jj
26229        real (kind=8) :: Fgb
26230 !       print *,"CALLING EQUAD"
26231 !c! Epol and Gpol analytical parameters
26232        alphapol1 = alphapol(itypi,itypj)
26233        alphapol2 = alphapol(itypj,itypi)
26234 !c! Fisocav and Gisocav analytical parameters
26235        al1  = alphiso(1,itypi,itypj)
26236        al2  = alphiso(2,itypi,itypj)
26237        al3  = alphiso(3,itypi,itypj)
26238        al4  = alphiso(4,itypi,itypj)
26239        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26240           + sigiso2(itypi,itypj)**2.0d0))
26241 !c!
26242        w1   = wqdip(1,itypi,itypj)
26243        w2   = wqdip(2,itypi,itypj)
26244        pis  = sig0head(itypi,itypj)
26245        eps_head = epshead(itypi,itypj)
26246 !c! First things first:
26247 !c! We need to do sc_grad's job with GB and Fcav
26248        eom1  = eps2der * eps2rt_om1 &
26249            - 2.0D0 * alf1 * eps3der&
26250            + sigder * sigsq_om1&
26251            + dCAVdOM1
26252        eom2  = eps2der * eps2rt_om2 &
26253            + 2.0D0 * alf2 * eps3der&
26254            + sigder * sigsq_om2&
26255            + dCAVdOM2
26256        eom12 =  evdwij  * eps1_om12 &
26257            + eps2der * eps2rt_om12 &
26258            - 2.0D0 * alf12 * eps3der&
26259            + sigder *sigsq_om12&
26260            + dCAVdOM12
26261 !c! now some magical transformations to project gradient into
26262 !c! three cartesian vectors
26263        DO k = 1, 3
26264       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26265       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26266       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26267 !c! this acts on hydrophobic center of interaction
26268       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26269               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26270               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26271       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26272               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26273               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26274 !c! this acts on Calpha
26275       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26276       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26277        END DO
26278 !c! sc_grad is done, now we will compute
26279        eheadtail = 0.0d0
26280        eom1 = 0.0d0
26281        eom2 = 0.0d0
26282        eom12 = 0.0d0
26283        DO istate = 1, nstate(itypi,itypj)
26284 !c*************************************************************
26285       IF (istate.ne.1) THEN
26286        IF (istate.lt.3) THEN
26287         ii = 1
26288        ELSE
26289         ii = 2
26290        END IF
26291       jj = istate/ii
26292       d1 = dhead(1,ii,itypi,itypj)
26293       d2 = dhead(2,jj,itypi,itypj)
26294       DO k = 1,3
26295        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26296        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26297        Rhead_distance(k) = chead(k,2) - chead(k,1)
26298       END DO
26299 !c! pitagoras (root of sum of squares)
26300       Rhead = dsqrt( &
26301              (Rhead_distance(1)*Rhead_distance(1))  &
26302            + (Rhead_distance(2)*Rhead_distance(2))  &
26303            + (Rhead_distance(3)*Rhead_distance(3)))
26304       END IF
26305       Rhead_sq = Rhead * Rhead
26306
26307 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26308 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26309       R1 = 0.0d0
26310       R2 = 0.0d0
26311       DO k = 1, 3
26312 !c! Calculate head-to-tail distances
26313        R1=R1+(ctail(k,2)-chead(k,1))**2
26314        R2=R2+(chead(k,2)-ctail(k,1))**2
26315       END DO
26316 !c! Pitagoras
26317       R1 = dsqrt(R1)
26318       R2 = dsqrt(R2)
26319       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26320 !c!        Ecl = 0.0d0
26321 !c!        write (*,*) "Ecl = ", Ecl
26322 !c! derivative of Ecl is Gcl...
26323       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26324 !c!        dGCLdR = 0.0d0
26325       dGCLdOM1 = 0.0d0
26326       dGCLdOM2 = 0.0d0
26327       dGCLdOM12 = 0.0d0
26328 !c!-------------------------------------------------------------------
26329 !c! Generalised Born Solvent Polarization
26330       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26331       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26332       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26333 !c!        Egb = 0.0d0
26334 !c!      write (*,*) "a1*a2 = ", a12sq
26335 !c!      write (*,*) "Rhead = ", Rhead
26336 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26337 !c!      write (*,*) "ee = ", ee
26338 !c!      write (*,*) "Fgb = ", Fgb
26339 !c!      write (*,*) "fac = ", eps_inout_fac
26340 !c!      write (*,*) "Qij = ", Qij
26341 !c!      write (*,*) "Egb = ", Egb
26342 !c! Derivative of Egb is Ggb...
26343 !c! dFGBdR is used by Quad's later...
26344       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26345       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26346              / ( 2.0d0 * Fgb )
26347       dGGBdR = dGGBdFGB * dFGBdR
26348 !c!        dGGBdR = 0.0d0
26349 !c!-------------------------------------------------------------------
26350 !c! Fisocav - isotropic cavity creation term
26351       pom = Rhead * csig
26352       top = al1 * (dsqrt(pom) + al2 * pom - al3)
26353       bot = (1.0d0 + al4 * pom**12.0d0)
26354       botsq = bot * bot
26355       FisoCav = top / bot
26356       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26357       dbot = 12.0d0 * al4 * pom ** 11.0d0
26358       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26359 !c!        dGCVdR = 0.0d0
26360 !c!-------------------------------------------------------------------
26361 !c! Polarization energy
26362 !c! Epol
26363       MomoFac1 = (1.0d0 - chi1 * sqom2)
26364       MomoFac2 = (1.0d0 - chi2 * sqom1)
26365       RR1  = ( R1 * R1 ) / MomoFac1
26366       RR2  = ( R2 * R2 ) / MomoFac2
26367       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26368       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26369       fgb1 = sqrt( RR1 + a12sq * ee1 )
26370       fgb2 = sqrt( RR2 + a12sq * ee2 )
26371       epol = 332.0d0 * eps_inout_fac * (&
26372       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26373 !c!        epol = 0.0d0
26374 !c! derivative of Epol is Gpol...
26375       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26376               / (fgb1 ** 5.0d0)
26377       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26378               / (fgb2 ** 5.0d0)
26379       dFGBdR1 = ( (R1 / MomoFac1) &
26380             * ( 2.0d0 - (0.5d0 * ee1) ) )&
26381             / ( 2.0d0 * fgb1 )
26382       dFGBdR2 = ( (R2 / MomoFac2) &
26383             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26384             / ( 2.0d0 * fgb2 )
26385       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26386              * ( 2.0d0 - 0.5d0 * ee1) ) &
26387              / ( 2.0d0 * fgb1 )
26388       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26389              * ( 2.0d0 - 0.5d0 * ee2) ) &
26390              / ( 2.0d0 * fgb2 )
26391       dPOLdR1 = dPOLdFGB1 * dFGBdR1
26392 !c!        dPOLdR1 = 0.0d0
26393       dPOLdR2 = dPOLdFGB2 * dFGBdR2
26394 !c!        dPOLdR2 = 0.0d0
26395       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26396 !c!        dPOLdOM1 = 0.0d0
26397       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26398       pom = (pis / Rhead)**6.0d0
26399       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26400 !c!        Elj = 0.0d0
26401 !c! derivative of Elj is Glj
26402       dGLJdR = 4.0d0 * eps_head &
26403           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26404           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26405 !c!        dGLJdR = 0.0d0
26406 !c!-------------------------------------------------------------------
26407 !c! Equad
26408        IF (Wqd.ne.0.0d0) THEN
26409       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26410            - 37.5d0  * ( sqom1 + sqom2 ) &
26411            + 157.5d0 * ( sqom1 * sqom2 ) &
26412            - 45.0d0  * om1*om2*om12
26413       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26414       Equad = fac * Beta1
26415 !c!        Equad = 0.0d0
26416 !c! derivative of Equad...
26417       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26418 !c!        dQUADdR = 0.0d0
26419       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26420 !c!        dQUADdOM1 = 0.0d0
26421       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26422 !c!        dQUADdOM2 = 0.0d0
26423       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26424        ELSE
26425        Beta1 = 0.0d0
26426        Equad = 0.0d0
26427       END IF
26428 !c!-------------------------------------------------------------------
26429 !c! Return the results
26430 !c! Angular stuff
26431       eom1 = dPOLdOM1 + dQUADdOM1
26432       eom2 = dPOLdOM2 + dQUADdOM2
26433       eom12 = dQUADdOM12
26434 !c! now some magical transformations to project gradient into
26435 !c! three cartesian vectors
26436       DO k = 1, 3
26437        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26438        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26439        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26440       END DO
26441 !c! Radial stuff
26442       DO k = 1, 3
26443        erhead(k) = Rhead_distance(k)/Rhead
26444        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26445        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26446       END DO
26447       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26448       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26449       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26450       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26451       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26452       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26453       facd1 = d1 * vbld_inv(i+nres)
26454       facd2 = d2 * vbld_inv(j+nres)
26455       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26456       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26457       DO k = 1, 3
26458        hawk   = erhead_tail(k,1) + &
26459        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26460        condor = erhead_tail(k,2) + &
26461        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26462
26463        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26464 !c! this acts on hydrophobic center of interaction
26465        gheadtail(k,1,1) = gheadtail(k,1,1) &
26466                    - dGCLdR * pom &
26467                    - dGGBdR * pom &
26468                    - dGCVdR * pom &
26469                    - dPOLdR1 * hawk &
26470                    - dPOLdR2 * (erhead_tail(k,2) &
26471       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26472                    - dGLJdR * pom &
26473                    - dQUADdR * pom&
26474                    - tuna(k) &
26475              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26476              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26477
26478        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26479 !c! this acts on hydrophobic center of interaction
26480        gheadtail(k,2,1) = gheadtail(k,2,1)  &
26481                    + dGCLdR * pom      &
26482                    + dGGBdR * pom      &
26483                    + dGCVdR * pom      &
26484                    + dPOLdR1 * (erhead_tail(k,1) &
26485       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26486                    + dPOLdR2 * condor &
26487                    + dGLJdR * pom &
26488                    + dQUADdR * pom &
26489                    + tuna(k) &
26490              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26491              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26492
26493 !c! this acts on Calpha
26494        gheadtail(k,3,1) = gheadtail(k,3,1)  &
26495                    - dGCLdR * erhead(k)&
26496                    - dGGBdR * erhead(k)&
26497                    - dGCVdR * erhead(k)&
26498                    - dPOLdR1 * erhead_tail(k,1)&
26499                    - dPOLdR2 * erhead_tail(k,2)&
26500                    - dGLJdR * erhead(k) &
26501                    - dQUADdR * erhead(k)&
26502                    - tuna(k)
26503 !c! this acts on Calpha
26504        gheadtail(k,4,1) = gheadtail(k,4,1)   &
26505                     + dGCLdR * erhead(k) &
26506                     + dGGBdR * erhead(k) &
26507                     + dGCVdR * erhead(k) &
26508                     + dPOLdR1 * erhead_tail(k,1) &
26509                     + dPOLdR2 * erhead_tail(k,2) &
26510                     + dGLJdR * erhead(k) &
26511                     + dQUADdR * erhead(k)&
26512                     + tuna(k)
26513       END DO
26514       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26515       eheadtail = eheadtail &
26516               + wstate(istate, itypi, itypj) &
26517               * dexp(-betaT * ener(istate))
26518 !c! foreach cartesian dimension
26519       DO k = 1, 3
26520 !c! foreach of two gvdwx and gvdwc
26521        DO l = 1, 4
26522         gheadtail(k,l,2) = gheadtail(k,l,2)  &
26523                      + wstate( istate, itypi, itypj ) &
26524                      * dexp(-betaT * ener(istate)) &
26525                      * gheadtail(k,l,1)
26526         gheadtail(k,l,1) = 0.0d0
26527        END DO
26528       END DO
26529        END DO
26530 !c! Here ended the gigantic DO istate = 1, 4, which starts
26531 !c! at the beggining of the subroutine
26532
26533        DO k = 1, 3
26534       DO l = 1, 4
26535        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26536       END DO
26537       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26538       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26539       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26540       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26541       DO l = 1, 4
26542        gheadtail(k,l,1) = 0.0d0
26543        gheadtail(k,l,2) = 0.0d0
26544       END DO
26545        END DO
26546        eheadtail = (-dlog(eheadtail)) / betaT
26547        dPOLdOM1 = 0.0d0
26548        dPOLdOM2 = 0.0d0
26549        dQUADdOM1 = 0.0d0
26550        dQUADdOM2 = 0.0d0
26551        dQUADdOM12 = 0.0d0
26552        RETURN
26553       END SUBROUTINE energy_quad
26554 !!-----------------------------------------------------------
26555       SUBROUTINE eqn(Epol)
26556       use comm_momo
26557       use calc_data
26558
26559       double precision  facd4, federmaus,epol
26560       alphapol1 = alphapol(itypi,itypj)
26561 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26562        R1 = 0.0d0
26563        DO k = 1, 3
26564 !c! Calculate head-to-tail distances
26565       R1=R1+(ctail(k,2)-chead(k,1))**2
26566        END DO
26567 !c! Pitagoras
26568        R1 = dsqrt(R1)
26569
26570 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26571 !c!     &        +dhead(1,1,itypi,itypj))**2))
26572 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26573 !c!     &        +dhead(2,1,itypi,itypj))**2))
26574 !c--------------------------------------------------------------------
26575 !c Polarization energy
26576 !c Epol
26577        MomoFac1 = (1.0d0 - chi1 * sqom2)
26578        RR1  = R1 * R1 / MomoFac1
26579        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26580        fgb1 = sqrt( RR1 + a12sq * ee1)
26581        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26582        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26583              / (fgb1 ** 5.0d0)
26584        dFGBdR1 = ( (R1 / MomoFac1) &
26585             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26586             / ( 2.0d0 * fgb1 )
26587        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26588             * (2.0d0 - 0.5d0 * ee1) ) &
26589             / (2.0d0 * fgb1)
26590        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26591 !c!       dPOLdR1 = 0.0d0
26592        dPOLdOM1 = 0.0d0
26593        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26594        DO k = 1, 3
26595       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26596        END DO
26597        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26598        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26599        facd1 = d1 * vbld_inv(i+nres)
26600        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26601
26602        DO k = 1, 3
26603       hawk = (erhead_tail(k,1) + &
26604       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26605
26606       gvdwx(k,i) = gvdwx(k,i) &
26607                - dPOLdR1 * hawk
26608       gvdwx(k,j) = gvdwx(k,j) &
26609                + dPOLdR1 * (erhead_tail(k,1) &
26610        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26611
26612       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26613       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26614
26615        END DO
26616        RETURN
26617       END SUBROUTINE eqn
26618       SUBROUTINE enq(Epol)
26619       use calc_data
26620       use comm_momo
26621        double precision facd3, adler,epol
26622        alphapol2 = alphapol(itypj,itypi)
26623 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26624        R2 = 0.0d0
26625        DO k = 1, 3
26626 !c! Calculate head-to-tail distances
26627       R2=R2+(chead(k,2)-ctail(k,1))**2
26628        END DO
26629 !c! Pitagoras
26630        R2 = dsqrt(R2)
26631
26632 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26633 !c!     &        +dhead(1,1,itypi,itypj))**2))
26634 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26635 !c!     &        +dhead(2,1,itypi,itypj))**2))
26636 !c------------------------------------------------------------------------
26637 !c Polarization energy
26638        MomoFac2 = (1.0d0 - chi2 * sqom1)
26639        RR2  = R2 * R2 / MomoFac2
26640        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26641        fgb2 = sqrt(RR2  + a12sq * ee2)
26642        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26643        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26644             / (fgb2 ** 5.0d0)
26645        dFGBdR2 = ( (R2 / MomoFac2)  &
26646             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26647             / (2.0d0 * fgb2)
26648        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26649             * (2.0d0 - 0.5d0 * ee2) ) &
26650             / (2.0d0 * fgb2)
26651        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26652 !c!       dPOLdR2 = 0.0d0
26653        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26654 !c!       dPOLdOM1 = 0.0d0
26655        dPOLdOM2 = 0.0d0
26656 !c!-------------------------------------------------------------------
26657 !c! Return the results
26658 !c! (See comments in Eqq)
26659        DO k = 1, 3
26660       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26661        END DO
26662        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26663        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26664        facd2 = d2 * vbld_inv(j+nres)
26665        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26666        DO k = 1, 3
26667       condor = (erhead_tail(k,2) &
26668        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26669
26670       gvdwx(k,i) = gvdwx(k,i) &
26671                - dPOLdR2 * (erhead_tail(k,2) &
26672        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26673       gvdwx(k,j) = gvdwx(k,j)   &
26674                + dPOLdR2 * condor
26675
26676       gvdwc(k,i) = gvdwc(k,i) &
26677                - dPOLdR2 * erhead_tail(k,2)
26678       gvdwc(k,j) = gvdwc(k,j) &
26679                + dPOLdR2 * erhead_tail(k,2)
26680
26681        END DO
26682       RETURN
26683       END SUBROUTINE enq
26684
26685       SUBROUTINE enq_cat(Epol)
26686       use calc_data
26687       use comm_momo
26688        double precision facd3, adler,epol
26689        alphapol2 = alphapolcat(itypi,itypj)
26690 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26691        R2 = 0.0d0
26692        DO k = 1, 3
26693 !c! Calculate head-to-tail distances
26694       R2=R2+(chead(k,2)-ctail(k,1))**2
26695        END DO
26696 !c! Pitagoras
26697        R2 = dsqrt(R2)
26698
26699 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26700 !c!     &        +dhead(1,1,itypi,itypj))**2))
26701 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26702 !c!     &        +dhead(2,1,itypi,itypj))**2))
26703 !c------------------------------------------------------------------------
26704 !c Polarization energy
26705        MomoFac2 = (1.0d0 - chi2 * sqom1)
26706        RR2  = R2 * R2 / MomoFac2
26707        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26708        fgb2 = sqrt(RR2  + a12sq * ee2)
26709        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26710        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26711             / (fgb2 ** 5.0d0)
26712        dFGBdR2 = ( (R2 / MomoFac2)  &
26713             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26714             / (2.0d0 * fgb2)
26715        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26716             * (2.0d0 - 0.5d0 * ee2) ) &
26717             / (2.0d0 * fgb2)
26718        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26719 !c!       dPOLdR2 = 0.0d0
26720        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26721 !c!       dPOLdOM1 = 0.0d0
26722        dPOLdOM2 = 0.0d0
26723
26724 !c!-------------------------------------------------------------------
26725 !c! Return the results
26726 !c! (See comments in Eqq)
26727        DO k = 1, 3
26728       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26729        END DO
26730        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26731        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26732        facd2 = d2 * vbld_inv(j+nres)
26733        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26734        DO k = 1, 3
26735       condor = (erhead_tail(k,2) &
26736        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26737
26738       gradpepcatx(k,i) = gradpepcatx(k,i) &
26739                - dPOLdR2 * (erhead_tail(k,2) &
26740        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26741 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
26742 !                   + dPOLdR2 * condor
26743
26744       gradpepcat(k,i) = gradpepcat(k,i) &
26745                - dPOLdR2 * erhead_tail(k,2)
26746       gradpepcat(k,j) = gradpepcat(k,j) &
26747                + dPOLdR2 * erhead_tail(k,2)
26748
26749        END DO
26750       RETURN
26751       END SUBROUTINE enq_cat
26752
26753       SUBROUTINE eqd(Ecl,Elj,Epol)
26754       use calc_data
26755       use comm_momo
26756        double precision  facd4, federmaus,ecl,elj,epol
26757        alphapol1 = alphapol(itypi,itypj)
26758        w1        = wqdip(1,itypi,itypj)
26759        w2        = wqdip(2,itypi,itypj)
26760        pis       = sig0head(itypi,itypj)
26761        eps_head   = epshead(itypi,itypj)
26762 !c!-------------------------------------------------------------------
26763 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26764        R1 = 0.0d0
26765        DO k = 1, 3
26766 !c! Calculate head-to-tail distances
26767       R1=R1+(ctail(k,2)-chead(k,1))**2
26768        END DO
26769 !c! Pitagoras
26770        R1 = dsqrt(R1)
26771
26772 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26773 !c!     &        +dhead(1,1,itypi,itypj))**2))
26774 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26775 !c!     &        +dhead(2,1,itypi,itypj))**2))
26776
26777 !c!-------------------------------------------------------------------
26778 !c! ecl
26779        sparrow  = w1 * Qi * om1
26780        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26781        Ecl = sparrow / Rhead**2.0d0 &
26782          - hawk    / Rhead**4.0d0
26783        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26784              + 4.0d0 * hawk    / Rhead**5.0d0
26785 !c! dF/dom1
26786        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26787 !c! dF/dom2
26788        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26789 !c--------------------------------------------------------------------
26790 !c Polarization energy
26791 !c Epol
26792        MomoFac1 = (1.0d0 - chi1 * sqom2)
26793        RR1  = R1 * R1 / MomoFac1
26794        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26795        fgb1 = sqrt( RR1 + a12sq * ee1)
26796        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26797 !c!       epol = 0.0d0
26798 !c!------------------------------------------------------------------
26799 !c! derivative of Epol is Gpol...
26800        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26801              / (fgb1 ** 5.0d0)
26802        dFGBdR1 = ( (R1 / MomoFac1)  &
26803            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26804            / ( 2.0d0 * fgb1 )
26805        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26806              * (2.0d0 - 0.5d0 * ee1) ) &
26807              / (2.0d0 * fgb1)
26808        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26809 !c!       dPOLdR1 = 0.0d0
26810        dPOLdOM1 = 0.0d0
26811        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26812 !c!       dPOLdOM2 = 0.0d0
26813 !c!-------------------------------------------------------------------
26814 !c! Elj
26815        pom = (pis / Rhead)**6.0d0
26816        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26817 !c! derivative of Elj is Glj
26818        dGLJdR = 4.0d0 * eps_head &
26819         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26820         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26821        DO k = 1, 3
26822       erhead(k) = Rhead_distance(k)/Rhead
26823       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26824        END DO
26825
26826        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26827        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26828        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26829        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26830        facd1 = d1 * vbld_inv(i+nres)
26831        facd2 = d2 * vbld_inv(j+nres)
26832        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26833
26834        DO k = 1, 3
26835       hawk = (erhead_tail(k,1) +  &
26836       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26837
26838       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26839       gvdwx(k,i) = gvdwx(k,i)  &
26840                - dGCLdR * pom&
26841                - dPOLdR1 * hawk &
26842                - dGLJdR * pom
26843
26844       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26845       gvdwx(k,j) = gvdwx(k,j)    &
26846                + dGCLdR * pom  &
26847                + dPOLdR1 * (erhead_tail(k,1) &
26848        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26849                + dGLJdR * pom
26850
26851
26852       gvdwc(k,i) = gvdwc(k,i)          &
26853                - dGCLdR * erhead(k)  &
26854                - dPOLdR1 * erhead_tail(k,1) &
26855                - dGLJdR * erhead(k)
26856
26857       gvdwc(k,j) = gvdwc(k,j)          &
26858                + dGCLdR * erhead(k)  &
26859                + dPOLdR1 * erhead_tail(k,1) &
26860                + dGLJdR * erhead(k)
26861
26862        END DO
26863        RETURN
26864       END SUBROUTINE eqd
26865       SUBROUTINE edq(Ecl,Elj,Epol)
26866 !       IMPLICIT NONE
26867        use comm_momo
26868       use calc_data
26869
26870       double precision  facd3, adler,ecl,elj,epol
26871        alphapol2 = alphapol(itypj,itypi)
26872        w1        = wqdip(1,itypi,itypj)
26873        w2        = wqdip(2,itypi,itypj)
26874        pis       = sig0head(itypi,itypj)
26875        eps_head  = epshead(itypi,itypj)
26876 !c!-------------------------------------------------------------------
26877 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26878        R2 = 0.0d0
26879        DO k = 1, 3
26880 !c! Calculate head-to-tail distances
26881       R2=R2+(chead(k,2)-ctail(k,1))**2
26882        END DO
26883 !c! Pitagoras
26884        R2 = dsqrt(R2)
26885
26886 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26887 !c!     &        +dhead(1,1,itypi,itypj))**2))
26888 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26889 !c!     &        +dhead(2,1,itypi,itypj))**2))
26890
26891
26892 !c!-------------------------------------------------------------------
26893 !c! ecl
26894        sparrow  = w1 * Qj * om1
26895        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26896        ECL = sparrow / Rhead**2.0d0 &
26897          - hawk    / Rhead**4.0d0
26898 !c!-------------------------------------------------------------------
26899 !c! derivative of ecl is Gcl
26900 !c! dF/dr part
26901        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26902              + 4.0d0 * hawk    / Rhead**5.0d0
26903 !c! dF/dom1
26904        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26905 !c! dF/dom2
26906        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26907 !c--------------------------------------------------------------------
26908 !c Polarization energy
26909 !c Epol
26910        MomoFac2 = (1.0d0 - chi2 * sqom1)
26911        RR2  = R2 * R2 / MomoFac2
26912        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26913        fgb2 = sqrt(RR2  + a12sq * ee2)
26914        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26915        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26916              / (fgb2 ** 5.0d0)
26917        dFGBdR2 = ( (R2 / MomoFac2)  &
26918              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26919              / (2.0d0 * fgb2)
26920        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26921             * (2.0d0 - 0.5d0 * ee2) ) &
26922             / (2.0d0 * fgb2)
26923        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26924 !c!       dPOLdR2 = 0.0d0
26925        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26926 !c!       dPOLdOM1 = 0.0d0
26927        dPOLdOM2 = 0.0d0
26928 !c!-------------------------------------------------------------------
26929 !c! Elj
26930        pom = (pis / Rhead)**6.0d0
26931        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26932 !c! derivative of Elj is Glj
26933        dGLJdR = 4.0d0 * eps_head &
26934          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26935          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26936 !c!-------------------------------------------------------------------
26937 !c! Return the results
26938 !c! (see comments in Eqq)
26939        DO k = 1, 3
26940       erhead(k) = Rhead_distance(k)/Rhead
26941       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26942        END DO
26943        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26944        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26945        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26946        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26947        facd1 = d1 * vbld_inv(i+nres)
26948        facd2 = d2 * vbld_inv(j+nres)
26949        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26950        DO k = 1, 3
26951       condor = (erhead_tail(k,2) &
26952        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26953
26954       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26955       gvdwx(k,i) = gvdwx(k,i) &
26956               - dGCLdR * pom &
26957               - dPOLdR2 * (erhead_tail(k,2) &
26958        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26959               - dGLJdR * pom
26960
26961       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26962       gvdwx(k,j) = gvdwx(k,j) &
26963               + dGCLdR * pom &
26964               + dPOLdR2 * condor &
26965               + dGLJdR * pom
26966
26967
26968       gvdwc(k,i) = gvdwc(k,i) &
26969               - dGCLdR * erhead(k) &
26970               - dPOLdR2 * erhead_tail(k,2) &
26971               - dGLJdR * erhead(k)
26972
26973       gvdwc(k,j) = gvdwc(k,j) &
26974               + dGCLdR * erhead(k) &
26975               + dPOLdR2 * erhead_tail(k,2) &
26976               + dGLJdR * erhead(k)
26977
26978        END DO
26979        RETURN
26980       END SUBROUTINE edq
26981
26982       SUBROUTINE edq_cat(Ecl,Elj,Epol)
26983       use comm_momo
26984       use calc_data
26985
26986       double precision  facd3, adler,ecl,elj,epol
26987        alphapol2 = alphapolcat(itypi,itypj)
26988        w1        = wqdipcat(1,itypi,itypj)
26989        w2        = wqdipcat(2,itypi,itypj)
26990        pis       = sig0headcat(itypi,itypj)
26991        eps_head  = epsheadcat(itypi,itypj)
26992 !c!-------------------------------------------------------------------
26993 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26994        R2 = 0.0d0
26995        DO k = 1, 3
26996 !c! Calculate head-to-tail distances
26997       R2=R2+(chead(k,2)-ctail(k,1))**2
26998        END DO
26999 !c! Pitagoras
27000        R2 = dsqrt(R2)
27001
27002 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27003 !c!     &        +dhead(1,1,itypi,itypj))**2))
27004 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27005 !c!     &        +dhead(2,1,itypi,itypj))**2))
27006
27007
27008 !c!-------------------------------------------------------------------
27009 !c! ecl
27010 !       write(iout,*) "KURWA2",Rhead
27011        sparrow  = w1 * Qj * om1
27012        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27013        ECL = sparrow / Rhead**2.0d0 &
27014          - hawk    / Rhead**4.0d0
27015 !c!-------------------------------------------------------------------
27016 !c! derivative of ecl is Gcl
27017 !c! dF/dr part
27018        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27019              + 4.0d0 * hawk    / Rhead**5.0d0
27020 !c! dF/dom1
27021        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27022 !c! dF/dom2
27023        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27024 !c--------------------------------------------------------------------
27025 !c--------------------------------------------------------------------
27026 !c Polarization energy
27027 !c Epol
27028        MomoFac2 = (1.0d0 - chi2 * sqom1)
27029        RR2  = R2 * R2 / MomoFac2
27030        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27031        fgb2 = sqrt(RR2  + a12sq * ee2)
27032        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27033        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27034              / (fgb2 ** 5.0d0)
27035        dFGBdR2 = ( (R2 / MomoFac2)  &
27036              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27037              / (2.0d0 * fgb2)
27038        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27039             * (2.0d0 - 0.5d0 * ee2) ) &
27040             / (2.0d0 * fgb2)
27041        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27042 !c!       dPOLdR2 = 0.0d0
27043        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27044 !c!       dPOLdOM1 = 0.0d0
27045        dPOLdOM2 = 0.0d0
27046 !c!-------------------------------------------------------------------
27047 !c! Elj
27048        pom = (pis / Rhead)**6.0d0
27049        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27050 !c! derivative of Elj is Glj
27051        dGLJdR = 4.0d0 * eps_head &
27052          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27053          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27054 !c!-------------------------------------------------------------------
27055
27056 !c! Return the results
27057 !c! (see comments in Eqq)
27058        DO k = 1, 3
27059       erhead(k) = Rhead_distance(k)/Rhead
27060       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27061        END DO
27062        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27063        erdxj = scalar( erhead(1), dC_norm(1,j) )
27064        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27065        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27066        facd1 = d1 * vbld_inv(i+nres)
27067        facd2 = d2 * vbld_inv(j)
27068        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27069        DO k = 1, 3
27070       condor = (erhead_tail(k,2) &
27071        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27072
27073       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27074       gradpepcatx(k,i) = gradpepcatx(k,i) &
27075               - dGCLdR * pom &
27076               - dPOLdR2 * (erhead_tail(k,2) &
27077        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27078               - dGLJdR * pom
27079
27080       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27081 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27082 !                  + dGCLdR * pom &
27083 !                  + dPOLdR2 * condor &
27084 !                  + dGLJdR * pom
27085
27086
27087       gradpepcat(k,i) = gradpepcat(k,i) &
27088               - dGCLdR * erhead(k) &
27089               - dPOLdR2 * erhead_tail(k,2) &
27090               - dGLJdR * erhead(k)
27091
27092       gradpepcat(k,j) = gradpepcat(k,j) &
27093               + dGCLdR * erhead(k) &
27094               + dPOLdR2 * erhead_tail(k,2) &
27095               + dGLJdR * erhead(k)
27096
27097        END DO
27098        RETURN
27099       END SUBROUTINE edq_cat
27100
27101       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27102       use comm_momo
27103       use calc_data
27104
27105       double precision  facd3, adler,ecl,elj,epol
27106        alphapol2 = alphapolcat(itypi,itypj)
27107        w1        = wqdipcat(1,itypi,itypj)
27108        w2        = wqdipcat(2,itypi,itypj)
27109        pis       = sig0headcat(itypi,itypj)
27110        eps_head  = epsheadcat(itypi,itypj)
27111 !c!-------------------------------------------------------------------
27112 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27113        R2 = 0.0d0
27114        DO k = 1, 3
27115 !c! Calculate head-to-tail distances
27116       R2=R2+(chead(k,2)-ctail(k,1))**2
27117        END DO
27118 !c! Pitagoras
27119        R2 = dsqrt(R2)
27120
27121 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27122 !c!     &        +dhead(1,1,itypi,itypj))**2))
27123 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27124 !c!     &        +dhead(2,1,itypi,itypj))**2))
27125
27126
27127 !c!-------------------------------------------------------------------
27128 !c! ecl
27129        sparrow  = w1 * Qj * om1
27130        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27131 !       print *,"CO2", itypi,itypj
27132 !       print *,"CO?!.", w1,w2,Qj,om1
27133        ECL = sparrow / Rhead**2.0d0 &
27134          - hawk    / Rhead**4.0d0
27135 !c!-------------------------------------------------------------------
27136 !c! derivative of ecl is Gcl
27137 !c! dF/dr part
27138        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27139              + 4.0d0 * hawk    / Rhead**5.0d0
27140 !c! dF/dom1
27141        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27142 !c! dF/dom2
27143        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27144 !c--------------------------------------------------------------------
27145 !c--------------------------------------------------------------------
27146 !c Polarization energy
27147 !c Epol
27148        MomoFac2 = (1.0d0 - chi2 * sqom1)
27149        RR2  = R2 * R2 / MomoFac2
27150        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27151        fgb2 = sqrt(RR2  + a12sq * ee2)
27152        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27153        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27154              / (fgb2 ** 5.0d0)
27155        dFGBdR2 = ( (R2 / MomoFac2)  &
27156              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27157              / (2.0d0 * fgb2)
27158        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27159             * (2.0d0 - 0.5d0 * ee2) ) &
27160             / (2.0d0 * fgb2)
27161        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27162 !c!       dPOLdR2 = 0.0d0
27163        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27164 !c!       dPOLdOM1 = 0.0d0
27165        dPOLdOM2 = 0.0d0
27166 !c!-------------------------------------------------------------------
27167 !c! Elj
27168        pom = (pis / Rhead)**6.0d0
27169        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27170 !c! derivative of Elj is Glj
27171        dGLJdR = 4.0d0 * eps_head &
27172          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27173          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27174 !c!-------------------------------------------------------------------
27175
27176 !c! Return the results
27177 !c! (see comments in Eqq)
27178        DO k = 1, 3
27179       erhead(k) = Rhead_distance(k)/Rhead
27180       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27181        END DO
27182        erdxi = scalar( erhead(1), dC_norm(1,i) )
27183        erdxj = scalar( erhead(1), dC_norm(1,j) )
27184        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27185        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27186        facd1 = d1 * vbld_inv(i+1)/2.0
27187        facd2 = d2 * vbld_inv(j)
27188        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27189        DO k = 1, 3
27190       condor = (erhead_tail(k,2) &
27191        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27192
27193       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27194 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27195 !                  - dGCLdR * pom &
27196 !                  - dPOLdR2 * (erhead_tail(k,2) &
27197 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27198 !                  - dGLJdR * pom
27199
27200       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27201 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27202 !                  + dGCLdR * pom &
27203 !                  + dPOLdR2 * condor &
27204 !                  + dGLJdR * pom
27205
27206
27207       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27208               - dGCLdR * erhead(k) &
27209               - dPOLdR2 * erhead_tail(k,2) &
27210               - dGLJdR * erhead(k))
27211       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27212               - dGCLdR * erhead(k) &
27213               - dPOLdR2 * erhead_tail(k,2) &
27214               - dGLJdR * erhead(k))
27215
27216
27217       gradpepcat(k,j) = gradpepcat(k,j) &
27218               + dGCLdR * erhead(k) &
27219               + dPOLdR2 * erhead_tail(k,2) &
27220               + dGLJdR * erhead(k)
27221
27222        END DO
27223        RETURN
27224       END SUBROUTINE edq_cat_pep
27225
27226       SUBROUTINE edd(ECL)
27227 !       IMPLICIT NONE
27228        use comm_momo
27229       use calc_data
27230
27231        double precision ecl
27232 !c!       csig = sigiso(itypi,itypj)
27233        w1 = wqdip(1,itypi,itypj)
27234        w2 = wqdip(2,itypi,itypj)
27235 !c!-------------------------------------------------------------------
27236 !c! ECL
27237        fac = (om12 - 3.0d0 * om1 * om2)
27238        c1 = (w1 / (Rhead**3.0d0)) * fac
27239        c2 = (w2 / Rhead ** 6.0d0) &
27240         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27241        ECL = c1 - c2
27242 !c!       write (*,*) "w1 = ", w1
27243 !c!       write (*,*) "w2 = ", w2
27244 !c!       write (*,*) "om1 = ", om1
27245 !c!       write (*,*) "om2 = ", om2
27246 !c!       write (*,*) "om12 = ", om12
27247 !c!       write (*,*) "fac = ", fac
27248 !c!       write (*,*) "c1 = ", c1
27249 !c!       write (*,*) "c2 = ", c2
27250 !c!       write (*,*) "Ecl = ", Ecl
27251 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27252 !c!       write (*,*) "c2_2 = ",
27253 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27254 !c!-------------------------------------------------------------------
27255 !c! dervative of ECL is GCL...
27256 !c! dECL/dr
27257        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27258        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27259         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27260        dGCLdR = c1 - c2
27261 !c! dECL/dom1
27262        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27263        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27264         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27265        dGCLdOM1 = c1 - c2
27266 !c! dECL/dom2
27267        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27268        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27269         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27270        dGCLdOM2 = c1 - c2
27271 !c! dECL/dom12
27272        c1 = w1 / (Rhead ** 3.0d0)
27273        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27274        dGCLdOM12 = c1 - c2
27275 !c!-------------------------------------------------------------------
27276 !c! Return the results
27277 !c! (see comments in Eqq)
27278        DO k= 1, 3
27279       erhead(k) = Rhead_distance(k)/Rhead
27280        END DO
27281        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27282        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27283        facd1 = d1 * vbld_inv(i+nres)
27284        facd2 = d2 * vbld_inv(j+nres)
27285        DO k = 1, 3
27286
27287       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27288       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27289       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27290       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27291
27292       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27293       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27294        END DO
27295        RETURN
27296       END SUBROUTINE edd
27297       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27298 !       IMPLICIT NONE
27299        use comm_momo
27300       use calc_data
27301
27302        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27303        eps_out=80.0d0
27304        itypi = itype(i,1)
27305        itypj = itype(j,1)
27306 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27307 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27308 !c!       t_bath = 300
27309 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27310        Rb=0.001986d0
27311        BetaT = 1.0d0 / (298.0d0 * Rb)
27312 !c! Gay-berne var's
27313        sig0ij = sigma( itypi,itypj )
27314        chi1   = chi( itypi, itypj )
27315        chi2   = chi( itypj, itypi )
27316        chi12  = chi1 * chi2
27317        chip1  = chipp( itypi, itypj )
27318        chip2  = chipp( itypj, itypi )
27319        chip12 = chip1 * chip2
27320 !       chi1=0.0
27321 !       chi2=0.0
27322 !       chi12=0.0
27323 !       chip1=0.0
27324 !       chip2=0.0
27325 !       chip12=0.0
27326 !c! not used by momo potential, but needed by sc_angular which is shared
27327 !c! by all energy_potential subroutines
27328        alf1   = 0.0d0
27329        alf2   = 0.0d0
27330        alf12  = 0.0d0
27331 !c! location, location, location
27332 !       xj  = c( 1, nres+j ) - xi
27333 !       yj  = c( 2, nres+j ) - yi
27334 !       zj  = c( 3, nres+j ) - zi
27335        dxj = dc_norm( 1, nres+j )
27336        dyj = dc_norm( 2, nres+j )
27337        dzj = dc_norm( 3, nres+j )
27338 !c! distance from center of chain(?) to polar/charged head
27339 !c!       write (*,*) "istate = ", 1
27340 !c!       write (*,*) "ii = ", 1
27341 !c!       write (*,*) "jj = ", 1
27342        d1 = dhead(1, 1, itypi, itypj)
27343        d2 = dhead(2, 1, itypi, itypj)
27344 !c! ai*aj from Fgb
27345        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27346 !c!       a12sq = a12sq * a12sq
27347 !c! charge of amino acid itypi is...
27348        Qi  = icharge(itypi)
27349        Qj  = icharge(itypj)
27350        Qij = Qi * Qj
27351 !c! chis1,2,12
27352        chis1 = chis(itypi,itypj)
27353        chis2 = chis(itypj,itypi)
27354        chis12 = chis1 * chis2
27355        sig1 = sigmap1(itypi,itypj)
27356        sig2 = sigmap2(itypi,itypj)
27357 !c!       write (*,*) "sig1 = ", sig1
27358 !c!       write (*,*) "sig2 = ", sig2
27359 !c! alpha factors from Fcav/Gcav
27360        b1cav = alphasur(1,itypi,itypj)
27361 !       b1cav=0.0
27362        b2cav = alphasur(2,itypi,itypj)
27363        b3cav = alphasur(3,itypi,itypj)
27364        b4cav = alphasur(4,itypi,itypj)
27365        wqd = wquad(itypi, itypj)
27366 !c! used by Fgb
27367        eps_in = epsintab(itypi,itypj)
27368        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27369 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27370 !c!-------------------------------------------------------------------
27371 !c! tail location and distance calculations
27372        Rtail = 0.0d0
27373        DO k = 1, 3
27374       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27375       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27376        END DO
27377 !c! tail distances will be themselves usefull elswhere
27378 !c1 (in Gcav, for example)
27379        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27380        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27381        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27382        Rtail = dsqrt(  &
27383         (Rtail_distance(1)*Rtail_distance(1))  &
27384       + (Rtail_distance(2)*Rtail_distance(2))  &
27385       + (Rtail_distance(3)*Rtail_distance(3)))
27386 !c!-------------------------------------------------------------------
27387 !c! Calculate location and distance between polar heads
27388 !c! distance between heads
27389 !c! for each one of our three dimensional space...
27390        d1 = dhead(1, 1, itypi, itypj)
27391        d2 = dhead(2, 1, itypi, itypj)
27392
27393        DO k = 1,3
27394 !c! location of polar head is computed by taking hydrophobic centre
27395 !c! and moving by a d1 * dc_norm vector
27396 !c! see unres publications for very informative images
27397       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27398       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27399 !c! distance
27400 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27401 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27402       Rhead_distance(k) = chead(k,2) - chead(k,1)
27403        END DO
27404 !c! pitagoras (root of sum of squares)
27405        Rhead = dsqrt(   &
27406         (Rhead_distance(1)*Rhead_distance(1)) &
27407       + (Rhead_distance(2)*Rhead_distance(2)) &
27408       + (Rhead_distance(3)*Rhead_distance(3)))
27409 !c!-------------------------------------------------------------------
27410 !c! zero everything that should be zero'ed
27411        Egb = 0.0d0
27412        ECL = 0.0d0
27413        Elj = 0.0d0
27414        Equad = 0.0d0
27415        Epol = 0.0d0
27416        eheadtail = 0.0d0
27417        dGCLdOM1 = 0.0d0
27418        dGCLdOM2 = 0.0d0
27419        dGCLdOM12 = 0.0d0
27420        dPOLdOM1 = 0.0d0
27421        dPOLdOM2 = 0.0d0
27422        RETURN
27423       END SUBROUTINE elgrad_init
27424
27425
27426       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27427       use comm_momo
27428       use calc_data
27429        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27430        eps_out=80.0d0
27431        itypi = itype(i,1)
27432        itypj = itype(j,5)
27433 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27434 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27435 !c!       t_bath = 300
27436 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27437        Rb=0.001986d0
27438        BetaT = 1.0d0 / (298.0d0 * Rb)
27439 !c! Gay-berne var's
27440        sig0ij = sigmacat( itypi,itypj )
27441        chi1   = chi1cat( itypi, itypj )
27442        chi2   = 0.0d0
27443        chi12  = 0.0d0
27444        chip1  = chipp1cat( itypi, itypj )
27445        chip2  = 0.0d0
27446        chip12 = 0.0d0
27447 !c! not used by momo potential, but needed by sc_angular which is shared
27448 !c! by all energy_potential subroutines
27449        alf1   = 0.0d0
27450        alf2   = 0.0d0
27451        alf12  = 0.0d0
27452        dxj = 0.0d0 !dc_norm( 1, nres+j )
27453        dyj = 0.0d0 !dc_norm( 2, nres+j )
27454        dzj = 0.0d0 !dc_norm( 3, nres+j )
27455 !c! distance from center of chain(?) to polar/charged head
27456        d1 = dheadcat(1, 1, itypi, itypj)
27457        d2 = dheadcat(2, 1, itypi, itypj)
27458 !c! ai*aj from Fgb
27459        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27460 !c!       a12sq = a12sq * a12sq
27461 !c! charge of amino acid itypi is...
27462        Qi  = icharge(itypi)
27463        Qj  = ichargecat(itypj)
27464        Qij = Qi * Qj
27465 !c! chis1,2,12
27466        chis1 = chis1cat(itypi,itypj)
27467        chis2 = 0.0d0
27468        chis12 = 0.0d0
27469        sig1 = sigmap1cat(itypi,itypj)
27470        sig2 = sigmap2cat(itypi,itypj)
27471 !c! alpha factors from Fcav/Gcav
27472        b1cav = alphasurcat(1,itypi,itypj)
27473        b2cav = alphasurcat(2,itypi,itypj)
27474        b3cav = alphasurcat(3,itypi,itypj)
27475        b4cav = alphasurcat(4,itypi,itypj)
27476        wqd = wquadcat(itypi, itypj)
27477 !c! used by Fgb
27478        eps_in = epsintabcat(itypi,itypj)
27479        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27480 !c!-------------------------------------------------------------------
27481 !c! tail location and distance calculations
27482        Rtail = 0.0d0
27483        DO k = 1, 3
27484       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27485       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27486        END DO
27487 !c! tail distances will be themselves usefull elswhere
27488 !c1 (in Gcav, for example)
27489        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27490        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27491        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27492        Rtail = dsqrt(  &
27493         (Rtail_distance(1)*Rtail_distance(1))  &
27494       + (Rtail_distance(2)*Rtail_distance(2))  &
27495       + (Rtail_distance(3)*Rtail_distance(3)))
27496 !c!-------------------------------------------------------------------
27497 !c! Calculate location and distance between polar heads
27498 !c! distance between heads
27499 !c! for each one of our three dimensional space...
27500        d1 = dheadcat(1, 1, itypi, itypj)
27501        d2 = dheadcat(2, 1, itypi, itypj)
27502
27503        DO k = 1,3
27504 !c! location of polar head is computed by taking hydrophobic centre
27505 !c! and moving by a d1 * dc_norm vector
27506 !c! see unres publications for very informative images
27507       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27508       chead(k,2) = c(k, j)
27509 !c! distance
27510 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27511 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27512       Rhead_distance(k) = chead(k,2) - chead(k,1)
27513        END DO
27514 !c! pitagoras (root of sum of squares)
27515        Rhead = dsqrt(   &
27516         (Rhead_distance(1)*Rhead_distance(1)) &
27517       + (Rhead_distance(2)*Rhead_distance(2)) &
27518       + (Rhead_distance(3)*Rhead_distance(3)))
27519 !c!-------------------------------------------------------------------
27520 !c! zero everything that should be zero'ed
27521        Egb = 0.0d0
27522        ECL = 0.0d0
27523        Elj = 0.0d0
27524        Equad = 0.0d0
27525        Epol = 0.0d0
27526        eheadtail = 0.0d0
27527        dGCLdOM1 = 0.0d0
27528        dGCLdOM2 = 0.0d0
27529        dGCLdOM12 = 0.0d0
27530        dPOLdOM1 = 0.0d0
27531        dPOLdOM2 = 0.0d0
27532        RETURN
27533       END SUBROUTINE elgrad_init_cat
27534
27535       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27536       use comm_momo
27537       use calc_data
27538        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27539        eps_out=80.0d0
27540        itypi = 10
27541        itypj = itype(j,5)
27542 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27543 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27544 !c!       t_bath = 300
27545 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27546        Rb=0.001986d0
27547        BetaT = 1.0d0 / (298.0d0 * Rb)
27548 !c! Gay-berne var's
27549        sig0ij = sigmacat( itypi,itypj )
27550        chi1   = chi1cat( itypi, itypj )
27551        chi2   = 0.0d0
27552        chi12  = 0.0d0
27553        chip1  = chipp1cat( itypi, itypj )
27554        chip2  = 0.0d0
27555        chip12 = 0.0d0
27556 !c! not used by momo potential, but needed by sc_angular which is shared
27557 !c! by all energy_potential subroutines
27558        alf1   = 0.0d0
27559        alf2   = 0.0d0
27560        alf12  = 0.0d0
27561        dxj = 0.0d0 !dc_norm( 1, nres+j )
27562        dyj = 0.0d0 !dc_norm( 2, nres+j )
27563        dzj = 0.0d0 !dc_norm( 3, nres+j )
27564 !c! distance from center of chain(?) to polar/charged head
27565        d1 = dheadcat(1, 1, itypi, itypj)
27566        d2 = dheadcat(2, 1, itypi, itypj)
27567 !c! ai*aj from Fgb
27568        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27569 !c!       a12sq = a12sq * a12sq
27570 !c! charge of amino acid itypi is...
27571        Qi  = 0
27572        Qj  = ichargecat(itypj)
27573 !       Qij = Qi * Qj
27574 !c! chis1,2,12
27575        chis1 = chis1cat(itypi,itypj)
27576        chis2 = 0.0d0
27577        chis12 = 0.0d0
27578        sig1 = sigmap1cat(itypi,itypj)
27579        sig2 = sigmap2cat(itypi,itypj)
27580 !c! alpha factors from Fcav/Gcav
27581        b1cav = alphasurcat(1,itypi,itypj)
27582        b2cav = alphasurcat(2,itypi,itypj)
27583        b3cav = alphasurcat(3,itypi,itypj)
27584        b4cav = alphasurcat(4,itypi,itypj)
27585        wqd = wquadcat(itypi, itypj)
27586 !c! used by Fgb
27587        eps_in = epsintabcat(itypi,itypj)
27588        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27589 !c!-------------------------------------------------------------------
27590 !c! tail location and distance calculations
27591        Rtail = 0.0d0
27592        DO k = 1, 3
27593       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
27594       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27595        END DO
27596 !c! tail distances will be themselves usefull elswhere
27597 !c1 (in Gcav, for example)
27598        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27599        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27600        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27601        Rtail = dsqrt(  &
27602         (Rtail_distance(1)*Rtail_distance(1))  &
27603       + (Rtail_distance(2)*Rtail_distance(2))  &
27604       + (Rtail_distance(3)*Rtail_distance(3)))
27605 !c!-------------------------------------------------------------------
27606 !c! Calculate location and distance between polar heads
27607 !c! distance between heads
27608 !c! for each one of our three dimensional space...
27609        d1 = dheadcat(1, 1, itypi, itypj)
27610        d2 = dheadcat(2, 1, itypi, itypj)
27611
27612        DO k = 1,3
27613 !c! location of polar head is computed by taking hydrophobic centre
27614 !c! and moving by a d1 * dc_norm vector
27615 !c! see unres publications for very informative images
27616       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
27617       chead(k,2) = c(k, j)
27618 !c! distance
27619 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27620 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27621       Rhead_distance(k) = chead(k,2) - chead(k,1)
27622        END DO
27623 !c! pitagoras (root of sum of squares)
27624        Rhead = dsqrt(   &
27625         (Rhead_distance(1)*Rhead_distance(1)) &
27626       + (Rhead_distance(2)*Rhead_distance(2)) &
27627       + (Rhead_distance(3)*Rhead_distance(3)))
27628 !c!-------------------------------------------------------------------
27629 !c! zero everything that should be zero'ed
27630        Egb = 0.0d0
27631        ECL = 0.0d0
27632        Elj = 0.0d0
27633        Equad = 0.0d0
27634        Epol = 0.0d0
27635        eheadtail = 0.0d0
27636        dGCLdOM1 = 0.0d0
27637        dGCLdOM2 = 0.0d0
27638        dGCLdOM12 = 0.0d0
27639        dPOLdOM1 = 0.0d0
27640        dPOLdOM2 = 0.0d0
27641        RETURN
27642       END SUBROUTINE elgrad_init_cat_pep
27643
27644       double precision function tschebyshev(m,n,x,y)
27645       implicit none
27646       integer i,m,n
27647       double precision x(n),y,yy(0:maxvar),aux
27648 !c Tschebyshev polynomial. Note that the first term is omitted
27649 !c m=0: the constant term is included
27650 !c m=1: the constant term is not included
27651       yy(0)=1.0d0
27652       yy(1)=y
27653       do i=2,n
27654       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27655       enddo
27656       aux=0.0d0
27657       do i=m,n
27658       aux=aux+x(i)*yy(i)
27659       enddo
27660       tschebyshev=aux
27661       return
27662       end function tschebyshev
27663 !C--------------------------------------------------------------------------
27664       double precision function gradtschebyshev(m,n,x,y)
27665       implicit none
27666       integer i,m,n
27667       double precision x(n+1),y,yy(0:maxvar),aux
27668 !c Tschebyshev polynomial. Note that the first term is omitted
27669 !c m=0: the constant term is included
27670 !c m=1: the constant term is not included
27671       yy(0)=1.0d0
27672       yy(1)=2.0d0*y
27673       do i=2,n
27674       yy(i)=2*y*yy(i-1)-yy(i-2)
27675       enddo
27676       aux=0.0d0
27677       do i=m,n
27678       aux=aux+x(i+1)*yy(i)*(i+1)
27679 !C        print *, x(i+1),yy(i),i
27680       enddo
27681       gradtschebyshev=aux
27682       return
27683       end function gradtschebyshev
27684
27685       subroutine make_SCSC_inter_list
27686       include 'mpif.h'
27687       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27688       real*8 :: dist_init, dist_temp,r_buff_list
27689       integer:: contlisti(250*nres),contlistj(250*nres)
27690 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
27691       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
27692       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
27693 !            print *,"START make_SC"
27694         r_buff_list=5.0
27695           ilist_sc=0
27696           do i=iatsc_s,iatsc_e
27697            itypi=iabs(itype(i,1))
27698            if (itypi.eq.ntyp1) cycle
27699            xi=c(1,nres+i)
27700            yi=c(2,nres+i)
27701            zi=c(3,nres+i)
27702           call to_box(xi,yi,zi)
27703            do iint=1,nint_gr(i)
27704 !           print *,"is it wrong", iint,i
27705             do j=istart(i,iint),iend(i,iint)
27706              itypj=iabs(itype(j,1))
27707              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
27708              if (itypj.eq.ntyp1) cycle
27709              xj=c(1,nres+j)
27710              yj=c(2,nres+j)
27711              zj=c(3,nres+j)
27712              call to_box(xj,yj,zj)
27713 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27714 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27715           xj=boxshift(xj-xi,boxxsize)
27716           yj=boxshift(yj-yi,boxysize)
27717           zj=boxshift(zj-zi,boxzsize)
27718           dist_init=xj**2+yj**2+zj**2
27719 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27720 ! r_buff_list is a read value for a buffer
27721              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27722 ! Here the list is created
27723              ilist_sc=ilist_sc+1
27724 ! this can be substituted by cantor and anti-cantor
27725              contlisti(ilist_sc)=i
27726              contlistj(ilist_sc)=j
27727
27728              endif
27729            enddo
27730            enddo
27731            enddo
27732 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27733 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27734 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
27735 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
27736 #ifdef DEBUG
27737       write (iout,*) "before MPIREDUCE",ilist_sc
27738       do i=1,ilist_sc
27739       write (iout,*) i,contlisti(i),contlistj(i)
27740       enddo
27741 #endif
27742       if (nfgtasks.gt.1)then
27743
27744       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27745         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27746 !        write(iout,*) "before bcast",g_ilist_sc
27747       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
27748                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
27749       displ(0)=0
27750       do i=1,nfgtasks-1,1
27751         displ(i)=i_ilist_sc(i-1)+displ(i-1)
27752       enddo
27753 !        write(iout,*) "before gather",displ(0),displ(1)
27754       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
27755                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
27756                    king,FG_COMM,IERR)
27757       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
27758                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
27759                    king,FG_COMM,IERR)
27760       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
27761 !        write(iout,*) "before bcast",g_ilist_sc
27762 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27763       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27764       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27765
27766 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27767
27768       else
27769       g_ilist_sc=ilist_sc
27770
27771       do i=1,ilist_sc
27772       newcontlisti(i)=contlisti(i)
27773       newcontlistj(i)=contlistj(i)
27774       enddo
27775       endif
27776
27777 #ifdef DEBUG
27778       write (iout,*) "after MPIREDUCE",g_ilist_sc
27779       do i=1,g_ilist_sc
27780       write (iout,*) i,newcontlisti(i),newcontlistj(i)
27781       enddo
27782 #endif
27783       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
27784       return
27785       end subroutine make_SCSC_inter_list
27786 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
27787
27788       subroutine make_SCp_inter_list
27789       use MD_data,  only: itime_mat
27790
27791       include 'mpif.h'
27792       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27793       real*8 :: dist_init, dist_temp,r_buff_list
27794       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
27795 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
27796       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
27797       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
27798 !            print *,"START make_SC"
27799       r_buff_list=5.0
27800           ilist_scp=0
27801       do i=iatscp_s,iatscp_e
27802       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27803       xi=0.5D0*(c(1,i)+c(1,i+1))
27804       yi=0.5D0*(c(2,i)+c(2,i+1))
27805       zi=0.5D0*(c(3,i)+c(3,i+1))
27806         call to_box(xi,yi,zi)
27807       do iint=1,nscp_gr(i)
27808
27809       do j=iscpstart(i,iint),iscpend(i,iint)
27810         itypj=iabs(itype(j,1))
27811         if (itypj.eq.ntyp1) cycle
27812 ! Uncomment following three lines for SC-p interactions
27813 !         xj=c(1,nres+j)-xi
27814 !         yj=c(2,nres+j)-yi
27815 !         zj=c(3,nres+j)-zi
27816 ! Uncomment following three lines for Ca-p interactions
27817 !          xj=c(1,j)-xi
27818 !          yj=c(2,j)-yi
27819 !          zj=c(3,j)-zi
27820         xj=c(1,j)
27821         yj=c(2,j)
27822         zj=c(3,j)
27823         call to_box(xj,yj,zj)
27824       xj=boxshift(xj-xi,boxxsize)
27825       yj=boxshift(yj-yi,boxysize)
27826       zj=boxshift(zj-zi,boxzsize)
27827       dist_init=xj**2+yj**2+zj**2
27828 #ifdef DEBUG
27829             ! r_buff_list is a read value for a buffer
27830              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
27831 ! Here the list is created
27832              ilist_scp_first=ilist_scp_first+1
27833 ! this can be substituted by cantor and anti-cantor
27834              contlistscpi_f(ilist_scp_first)=i
27835              contlistscpj_f(ilist_scp_first)=j
27836             endif
27837 #endif
27838 ! r_buff_list is a read value for a buffer
27839              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27840 ! Here the list is created
27841              ilist_scp=ilist_scp+1
27842 ! this can be substituted by cantor and anti-cantor
27843              contlistscpi(ilist_scp)=i
27844              contlistscpj(ilist_scp)=j
27845             endif
27846            enddo
27847            enddo
27848            enddo
27849 #ifdef DEBUG
27850       write (iout,*) "before MPIREDUCE",ilist_scp
27851       do i=1,ilist_scp
27852       write (iout,*) i,contlistscpi(i),contlistscpj(i)
27853       enddo
27854 #endif
27855       if (nfgtasks.gt.1)then
27856
27857       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
27858         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27859 !        write(iout,*) "before bcast",g_ilist_sc
27860       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
27861                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
27862       displ(0)=0
27863       do i=1,nfgtasks-1,1
27864         displ(i)=i_ilist_scp(i-1)+displ(i-1)
27865       enddo
27866 !        write(iout,*) "before gather",displ(0),displ(1)
27867       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
27868                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
27869                    king,FG_COMM,IERR)
27870       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
27871                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
27872                    king,FG_COMM,IERR)
27873       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
27874 !        write(iout,*) "before bcast",g_ilist_sc
27875 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27876       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27877       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27878
27879 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27880
27881       else
27882       g_ilist_scp=ilist_scp
27883
27884       do i=1,ilist_scp
27885       newcontlistscpi(i)=contlistscpi(i)
27886       newcontlistscpj(i)=contlistscpj(i)
27887       enddo
27888       endif
27889
27890 #ifdef DEBUG
27891       write (iout,*) "after MPIREDUCE",g_ilist_scp
27892       do i=1,g_ilist_scp
27893       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
27894       enddo
27895
27896 !      if (ifirstrun.eq.0) ifirstrun=1
27897 !      do i=1,ilist_scp_first
27898 !       do j=1,g_ilist_scp
27899 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
27900 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
27901 !        enddo
27902 !       print *,itime_mat,"ERROR matrix needs updating"
27903 !       print *,contlistscpi_f(i),contlistscpj_f(i)
27904 !  126  continue
27905 !      enddo
27906 #endif
27907       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
27908
27909       return
27910       end subroutine make_SCp_inter_list
27911
27912 !-----------------------------------------------------------------------------
27913 !-----------------------------------------------------------------------------
27914
27915
27916       subroutine make_pp_inter_list
27917       include 'mpif.h'
27918       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27919       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
27920       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
27921       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
27922       integer:: contlistppi(250*nres),contlistppj(250*nres)
27923 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
27924       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
27925       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
27926 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
27927             ilist_pp=0
27928       r_buff_list=5.0
27929       do i=iatel_s,iatel_e
27930         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27931         dxi=dc(1,i)
27932         dyi=dc(2,i)
27933         dzi=dc(3,i)
27934         dx_normi=dc_norm(1,i)
27935         dy_normi=dc_norm(2,i)
27936         dz_normi=dc_norm(3,i)
27937         xmedi=c(1,i)+0.5d0*dxi
27938         ymedi=c(2,i)+0.5d0*dyi
27939         zmedi=c(3,i)+0.5d0*dzi
27940
27941         call to_box(xmedi,ymedi,zmedi)
27942         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
27943 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27944 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27945
27946 ! 1,j)
27947              do j=ielstart(i),ielend(i)
27948 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27949           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27950           dxj=dc(1,j)
27951           dyj=dc(2,j)
27952           dzj=dc(3,j)
27953           dx_normj=dc_norm(1,j)
27954           dy_normj=dc_norm(2,j)
27955           dz_normj=dc_norm(3,j)
27956 !          xj=c(1,j)+0.5D0*dxj-xmedi
27957 !          yj=c(2,j)+0.5D0*dyj-ymedi
27958 !          zj=c(3,j)+0.5D0*dzj-zmedi
27959           xj=c(1,j)+0.5D0*dxj
27960           yj=c(2,j)+0.5D0*dyj
27961           zj=c(3,j)+0.5D0*dzj
27962           call to_box(xj,yj,zj)
27963 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27964 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27965           xj=boxshift(xj-xmedi,boxxsize)
27966           yj=boxshift(yj-ymedi,boxysize)
27967           zj=boxshift(zj-zmedi,boxzsize)
27968           dist_init=xj**2+yj**2+zj**2
27969       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27970 ! Here the list is created
27971                  ilist_pp=ilist_pp+1
27972 ! this can be substituted by cantor and anti-cantor
27973                  contlistppi(ilist_pp)=i
27974                  contlistppj(ilist_pp)=j
27975               endif
27976 !             enddo
27977              enddo
27978              enddo
27979 #ifdef DEBUG
27980       write (iout,*) "before MPIREDUCE",ilist_pp
27981       do i=1,ilist_pp
27982       write (iout,*) i,contlistppi(i),contlistppj(i)
27983       enddo
27984 #endif
27985       if (nfgtasks.gt.1)then
27986
27987         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
27988           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27989 !        write(iout,*) "before bcast",g_ilist_sc
27990         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
27991                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
27992         displ(0)=0
27993         do i=1,nfgtasks-1,1
27994           displ(i)=i_ilist_pp(i-1)+displ(i-1)
27995         enddo
27996 !        write(iout,*) "before gather",displ(0),displ(1)
27997         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
27998                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
27999                          king,FG_COMM,IERR)
28000         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
28001                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
28002                          king,FG_COMM,IERR)
28003         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
28004 !        write(iout,*) "before bcast",g_ilist_sc
28005 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28006         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28007         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28008
28009 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28010
28011         else
28012         g_ilist_pp=ilist_pp
28013
28014         do i=1,ilist_pp
28015         newcontlistppi(i)=contlistppi(i)
28016         newcontlistppj(i)=contlistppj(i)
28017         enddo
28018         endif
28019         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
28020 #ifdef DEBUG
28021       write (iout,*) "after MPIREDUCE",g_ilist_pp
28022       do i=1,g_ilist_pp
28023       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
28024       enddo
28025 #endif
28026       return
28027       end subroutine make_pp_inter_list
28028
28029 !-----------------------------------------------------------------------------
28030       double precision function boxshift(x,boxsize)
28031       implicit none
28032       double precision x,boxsize
28033       double precision xtemp
28034       xtemp=dmod(x,boxsize)
28035       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
28036         boxshift=xtemp-boxsize
28037       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
28038         boxshift=xtemp+boxsize
28039       else
28040         boxshift=xtemp
28041       endif
28042       return
28043       end function boxshift
28044 !-----------------------------------------------------------------------------
28045       subroutine to_box(xi,yi,zi)
28046       implicit none
28047 !      include 'DIMENSIONS'
28048 !      include 'COMMON.CHAIN'
28049       double precision xi,yi,zi
28050       xi=dmod(xi,boxxsize)
28051       if (xi.lt.0.0d0) xi=xi+boxxsize
28052       yi=dmod(yi,boxysize)
28053       if (yi.lt.0.0d0) yi=yi+boxysize
28054       zi=dmod(zi,boxzsize)
28055       if (zi.lt.0.0d0) zi=zi+boxzsize
28056       return
28057       end subroutine to_box
28058 !--------------------------------------------------------------------------
28059       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
28060       implicit none
28061 !      include 'DIMENSIONS'
28062 !      include 'COMMON.IOUNITS'
28063 !      include 'COMMON.CHAIN'
28064       double precision xi,yi,zi,sslipi,ssgradlipi
28065       double precision fracinbuf
28066 !      double precision sscalelip,sscagradlip
28067 #ifdef DEBUG
28068       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
28069       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
28070       write (iout,*) "xi yi zi",xi,yi,zi
28071 #endif
28072       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
28073 ! the energy transfer exist
28074         if (zi.lt.buflipbot) then
28075 ! what fraction I am in
28076           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
28077 ! lipbufthick is thickenes of lipid buffore
28078           sslipi=sscalelip(fracinbuf)
28079           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
28080         elseif (zi.gt.bufliptop) then
28081           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
28082           sslipi=sscalelip(fracinbuf)
28083           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
28084         else
28085           sslipi=1.0d0
28086           ssgradlipi=0.0
28087         endif
28088       else
28089         sslipi=0.0d0
28090         ssgradlipi=0.0
28091       endif
28092 #ifdef DEBUG
28093       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
28094 #endif
28095       return
28096       end subroutine lipid_layer
28097
28098 !--------------------------------------------------------------------------
28099 !--------------------------------------------------------------------------
28100       end module energy