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 !C      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           enddo
12530         enddo
12531       else
12532 !- split gradient check
12533         call zerograd
12534         call etotal_long(energia)
12535 !el        call enerprint(energia)
12536         call cartgrad
12537         icall =1
12538         do i=1,nres
12539           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12540           (gxcart(j,i),j=1,3)
12541         enddo
12542         do j=1,3
12543           grad_s(j,0)=gcart(j,0)
12544         enddo
12545         do i=1,nres
12546           do j=1,3
12547             grad_s(j,i)=gcart(j,i)
12548             grad_s(j+3,i)=gxcart(j,i)
12549           enddo
12550         enddo
12551         call zerograd
12552         call etotal_short(energia)
12553         call enerprint(energia)
12554         call cartgrad
12555         icall =1
12556         do i=1,nres
12557           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12558           (gxcart(j,i),j=1,3)
12559         enddo
12560         do j=1,3
12561           grad_s1(j,0)=gcart(j,0)
12562         enddo
12563         do i=1,nres
12564           do j=1,3
12565             grad_s1(j,i)=gcart(j,i)
12566             grad_s1(j+3,i)=gxcart(j,i)
12567           enddo
12568         enddo
12569       endif
12570       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12571 !      do i=1,nres
12572       do i=nnt,nct
12573         do j=1,3
12574           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12575           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12576         ddc(j)=c(j,i)
12577         ddx(j)=c(j,i+nres)
12578           dcnorm_safe1(j)=dc_norm(j,i-1)
12579           dcnorm_safe2(j)=dc_norm(j,i)
12580           dxnorm_safe(j)=dc_norm(j,i+nres)
12581         enddo
12582       do j=1,3
12583         c(j,i)=ddc(j)+aincr
12584           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12585           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12586           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12587           dc(j,i)=c(j,i+1)-c(j,i)
12588           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12589           call int_from_cart1(.false.)
12590           if (.not.split_ene) then
12591            call zerograd
12592             call etotal(energia1)
12593             etot1=energia1(0)
12594             write (iout,*) "ij",i,j," etot1",etot1
12595           else
12596 !- split gradient
12597             call etotal_long(energia1)
12598             etot11=energia1(0)
12599             call etotal_short(energia1)
12600             etot12=energia1(0)
12601           endif
12602 !- end split gradient
12603 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12604         c(j,i)=ddc(j)-aincr
12605           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12606           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12607           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12608           dc(j,i)=c(j,i+1)-c(j,i)
12609           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12610           call int_from_cart1(.false.)
12611           if (.not.split_ene) then
12612             call zerograd
12613             call etotal(energia1)
12614             etot2=energia1(0)
12615             write (iout,*) "ij",i,j," etot2",etot2
12616           ggg(j)=(etot1-etot2)/(2*aincr)
12617           else
12618 !- split gradient
12619             call etotal_long(energia1)
12620             etot21=energia1(0)
12621           ggg(j)=(etot11-etot21)/(2*aincr)
12622             call etotal_short(energia1)
12623             etot22=energia1(0)
12624           ggg1(j)=(etot12-etot22)/(2*aincr)
12625 !- end split gradient
12626 !            write (iout,*) "etot21",etot21," etot22",etot22
12627           endif
12628 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12629         c(j,i)=ddc(j)
12630           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12631           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12632           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12633           dc(j,i)=c(j,i+1)-c(j,i)
12634           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12635           dc_norm(j,i-1)=dcnorm_safe1(j)
12636           dc_norm(j,i)=dcnorm_safe2(j)
12637           dc_norm(j,i+nres)=dxnorm_safe(j)
12638         enddo
12639       do j=1,3
12640         c(j,i+nres)=ddx(j)+aincr
12641           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12642           call int_from_cart1(.false.)
12643           if (.not.split_ene) then
12644             call zerograd
12645             call etotal(energia1)
12646             etot1=energia1(0)
12647           else
12648 !- split gradient
12649             call etotal_long(energia1)
12650             etot11=energia1(0)
12651             call etotal_short(energia1)
12652             etot12=energia1(0)
12653           endif
12654 !- end split gradient
12655         c(j,i+nres)=ddx(j)-aincr
12656           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12657           call int_from_cart1(.false.)
12658           if (.not.split_ene) then
12659            call zerograd
12660            call etotal(energia1)
12661             etot2=energia1(0)
12662           ggg(j+3)=(etot1-etot2)/(2*aincr)
12663           else
12664 !- split gradient
12665             call etotal_long(energia1)
12666             etot21=energia1(0)
12667           ggg(j+3)=(etot11-etot21)/(2*aincr)
12668             call etotal_short(energia1)
12669             etot22=energia1(0)
12670           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12671 !- end split gradient
12672           endif
12673 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12674         c(j,i+nres)=ddx(j)
12675           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12676           dc_norm(j,i+nres)=dxnorm_safe(j)
12677           call int_from_cart1(.false.)
12678         enddo
12679       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12680          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12681         if (split_ene) then
12682           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12683          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12684          k=1,6)
12685          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12686          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12687          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12688         endif
12689       enddo
12690       return
12691       end subroutine check_ecartint
12692 #else
12693 !-----------------------------------------------------------------------------
12694       subroutine check_ecartint
12695 ! Check the gradient of the energy in Cartesian coordinates.
12696       use io_base, only: intout
12697 !      implicit real*8 (a-h,o-z)
12698 !      include 'DIMENSIONS'
12699 !      include 'COMMON.CONTROL'
12700 !      include 'COMMON.CHAIN'
12701 !      include 'COMMON.DERIV'
12702 !      include 'COMMON.IOUNITS'
12703 !      include 'COMMON.VAR'
12704 !      include 'COMMON.CONTACTS'
12705 !      include 'COMMON.MD'
12706 !      include 'COMMON.LOCAL'
12707 !      include 'COMMON.SPLITELE'
12708       use comm_srutu
12709 !el      integer :: icall
12710 !el      common /srutu/ icall
12711       real(kind=8),dimension(6) :: ggg,ggg1
12712       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12713       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12714       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12715       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12716       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12717       real(kind=8),dimension(0:n_ene) :: energia,energia1
12718       integer :: uiparm(1)
12719       real(kind=8) :: urparm(1)
12720 !EL      external fdum
12721       integer :: i,j,k,nf
12722       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12723                    etot21,etot22
12724       r_cut=2.0d0
12725       rlambd=0.3d0
12726       icg=1
12727       nf=0
12728       nfl=0
12729       call intout
12730 !      call intcartderiv
12731 !      call checkintcartgrad
12732       call zerograd
12733       aincr=1.0D-6
12734       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12735       nf=0
12736       icall=0
12737       call geom_to_var(nvar,x)
12738       if (.not.split_ene) then
12739         call etotal(energia)
12740         etot=energia(0)
12741 !el        call enerprint(energia)
12742         call cartgrad
12743         icall =1
12744         do i=1,nres
12745           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12746         enddo
12747         do j=1,3
12748           grad_s(j,0)=gcart(j,0)
12749         enddo
12750         do i=1,nres
12751           do j=1,3
12752             grad_s(j,i)=gcart(j,i)
12753 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12754
12755 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12756             grad_s(j+3,i)=gxcart(j,i)
12757           enddo
12758         enddo
12759       else
12760 !- split gradient check
12761         call zerograd
12762         call etotal_long(energia)
12763 !el        call enerprint(energia)
12764         call cartgrad
12765         icall =1
12766         do i=1,nres
12767           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12768           (gxcart(j,i),j=1,3)
12769         enddo
12770         do j=1,3
12771           grad_s(j,0)=gcart(j,0)
12772         enddo
12773         do i=1,nres
12774           do j=1,3
12775             grad_s(j,i)=gcart(j,i)
12776 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12777             grad_s(j+3,i)=gxcart(j,i)
12778           enddo
12779         enddo
12780         call zerograd
12781         call etotal_short(energia)
12782 !el        call enerprint(energia)
12783         call cartgrad
12784         icall =1
12785         do i=1,nres
12786           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12787           (gxcart(j,i),j=1,3)
12788         enddo
12789         do j=1,3
12790           grad_s1(j,0)=gcart(j,0)
12791         enddo
12792         do i=1,nres
12793           do j=1,3
12794             grad_s1(j,i)=gcart(j,i)
12795             grad_s1(j+3,i)=gxcart(j,i)
12796           enddo
12797         enddo
12798       endif
12799       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12800       do i=0,nres
12801         do j=1,3
12802         xx(j)=c(j,i+nres)
12803         ddc(j)=dc(j,i)
12804         ddx(j)=dc(j,i+nres)
12805           do k=1,3
12806             dcnorm_safe(k)=dc_norm(k,i)
12807             dxnorm_safe(k)=dc_norm(k,i+nres)
12808           enddo
12809         enddo
12810       do j=1,3
12811         dc(j,i)=ddc(j)+aincr
12812           call chainbuild_cart
12813 #ifdef MPI
12814 ! Broadcast the order to compute internal coordinates to the slaves.
12815 !          if (nfgtasks.gt.1)
12816 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12817 #endif
12818 !          call int_from_cart1(.false.)
12819           if (.not.split_ene) then
12820            call zerograd
12821             call etotal(energia1)
12822             etot1=energia1(0)
12823 !            call enerprint(energia1)
12824           else
12825 !- split gradient
12826             call etotal_long(energia1)
12827             etot11=energia1(0)
12828             call etotal_short(energia1)
12829             etot12=energia1(0)
12830 !            write (iout,*) "etot11",etot11," etot12",etot12
12831           endif
12832 !- end split gradient
12833 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12834         dc(j,i)=ddc(j)-aincr
12835           call chainbuild_cart
12836 !          call int_from_cart1(.false.)
12837           if (.not.split_ene) then
12838                   call zerograd
12839             call etotal(energia1)
12840             etot2=energia1(0)
12841           ggg(j)=(etot1-etot2)/(2*aincr)
12842           else
12843 !- split gradient
12844             call etotal_long(energia1)
12845             etot21=energia1(0)
12846           ggg(j)=(etot11-etot21)/(2*aincr)
12847             call etotal_short(energia1)
12848             etot22=energia1(0)
12849           ggg1(j)=(etot12-etot22)/(2*aincr)
12850 !- end split gradient
12851 !            write (iout,*) "etot21",etot21," etot22",etot22
12852           endif
12853 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12854         dc(j,i)=ddc(j)
12855           call chainbuild_cart
12856         enddo
12857       do j=1,3
12858         dc(j,i+nres)=ddx(j)+aincr
12859           call chainbuild_cart
12860 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12861 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12862 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12863 !          write (iout,*) "dxnormnorm",dsqrt(
12864 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12865 !          write (iout,*) "dxnormnormsafe",dsqrt(
12866 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12867 !          write (iout,*)
12868           if (.not.split_ene) then
12869             call zerograd
12870             call etotal(energia1)
12871             etot1=energia1(0)
12872           else
12873 !- split gradient
12874             call etotal_long(energia1)
12875             etot11=energia1(0)
12876             call etotal_short(energia1)
12877             etot12=energia1(0)
12878           endif
12879 !- end split gradient
12880 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12881         dc(j,i+nres)=ddx(j)-aincr
12882           call chainbuild_cart
12883 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12884 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12885 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12886 !          write (iout,*)
12887 !          write (iout,*) "dxnormnorm",dsqrt(
12888 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12889 !          write (iout,*) "dxnormnormsafe",dsqrt(
12890 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12891           if (.not.split_ene) then
12892             call zerograd
12893             call etotal(energia1)
12894             etot2=energia1(0)
12895           ggg(j+3)=(etot1-etot2)/(2*aincr)
12896           else
12897 !- split gradient
12898             call etotal_long(energia1)
12899             etot21=energia1(0)
12900           ggg(j+3)=(etot11-etot21)/(2*aincr)
12901             call etotal_short(energia1)
12902             etot22=energia1(0)
12903           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12904 !- end split gradient
12905           endif
12906 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12907         dc(j,i+nres)=ddx(j)
12908           call chainbuild_cart
12909         enddo
12910       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12911          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12912         if (split_ene) then
12913           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12914          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12915          k=1,6)
12916          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12917          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12918          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12919         endif
12920       enddo
12921       return
12922       end subroutine check_ecartint
12923 #endif
12924 !-----------------------------------------------------------------------------
12925       subroutine check_eint
12926 ! Check the gradient of energy in internal coordinates.
12927 !      implicit real*8 (a-h,o-z)
12928 !      include 'DIMENSIONS'
12929 !      include 'COMMON.CHAIN'
12930 !      include 'COMMON.DERIV'
12931 !      include 'COMMON.IOUNITS'
12932 !      include 'COMMON.VAR'
12933 !      include 'COMMON.GEO'
12934       use comm_srutu
12935 !el      integer :: icall
12936 !el      common /srutu/ icall
12937       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12938       integer :: uiparm(1)
12939       real(kind=8) :: urparm(1)
12940       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12941       character(len=6) :: key
12942 !EL      external fdum
12943       integer :: i,ii,nf
12944       real(kind=8) :: xi,aincr,etot,etot1,etot2
12945       call zerograd
12946       aincr=1.0D-7
12947       print '(a)','Calling CHECK_INT.'
12948       nf=0
12949       nfl=0
12950       icg=1
12951       call geom_to_var(nvar,x)
12952       call var_to_geom(nvar,x)
12953       call chainbuild
12954       icall=1
12955 !      print *,'ICG=',ICG
12956       call etotal(energia)
12957       etot = energia(0)
12958 !el      call enerprint(energia)
12959 !      print *,'ICG=',ICG
12960 #ifdef MPL
12961       if (MyID.ne.BossID) then
12962         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12963         nf=x(nvar+1)
12964         nfl=x(nvar+2)
12965         icg=x(nvar+3)
12966       endif
12967 #endif
12968       nf=1
12969       nfl=3
12970 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12971       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12972 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12973       icall=1
12974       do i=1,nvar
12975         xi=x(i)
12976         x(i)=xi-0.5D0*aincr
12977         call var_to_geom(nvar,x)
12978         call chainbuild
12979         call etotal(energia1)
12980         etot1=energia1(0)
12981         x(i)=xi+0.5D0*aincr
12982         call var_to_geom(nvar,x)
12983         call chainbuild
12984         call etotal(energia2)
12985         etot2=energia2(0)
12986         gg(i)=(etot2-etot1)/aincr
12987         write (iout,*) i,etot1,etot2
12988         x(i)=xi
12989       enddo
12990       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12991           '     RelDiff*100% '
12992       do i=1,nvar
12993         if (i.le.nphi) then
12994           ii=i
12995           key = ' phi'
12996         else if (i.le.nphi+ntheta) then
12997           ii=i-nphi
12998           key=' theta'
12999         else if (i.le.nphi+ntheta+nside) then
13000            ii=i-(nphi+ntheta)
13001            key=' alpha'
13002         else
13003            ii=i-(nphi+ntheta+nside)
13004            key=' omega'
13005         endif
13006         write (iout,'(i3,a,i3,3(1pd16.6))') &
13007        i,key,ii,gg(i),gana(i),&
13008        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13009       enddo
13010       return
13011       end subroutine check_eint
13012 !-----------------------------------------------------------------------------
13013 ! econstr_local.F
13014 !-----------------------------------------------------------------------------
13015       subroutine Econstr_back
13016 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13017 !      implicit real*8 (a-h,o-z)
13018 !      include 'DIMENSIONS'
13019 !      include 'COMMON.CONTROL'
13020 !      include 'COMMON.VAR'
13021 !      include 'COMMON.MD'
13022       use MD_data
13023 !#ifndef LANG0
13024 !      include 'COMMON.LANGEVIN'
13025 !#else
13026 !      include 'COMMON.LANGEVIN.lang0'
13027 !#endif
13028 !      include 'COMMON.CHAIN'
13029 !      include 'COMMON.DERIV'
13030 !      include 'COMMON.GEO'
13031 !      include 'COMMON.LOCAL'
13032 !      include 'COMMON.INTERACT'
13033 !      include 'COMMON.IOUNITS'
13034 !      include 'COMMON.NAMES'
13035 !      include 'COMMON.TIME1'
13036       integer :: i,j,ii,k
13037       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13038
13039       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13040       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13041       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13042
13043       Uconst_back=0.0d0
13044       do i=1,nres
13045         dutheta(i)=0.0d0
13046         dugamma(i)=0.0d0
13047         do j=1,3
13048           duscdiff(j,i)=0.0d0
13049           duscdiffx(j,i)=0.0d0
13050         enddo
13051       enddo
13052       do i=1,nfrag_back
13053         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13054 !
13055 ! Deviations from theta angles
13056 !
13057         utheta_i=0.0d0
13058         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13059           dtheta_i=theta(j)-thetaref(j)
13060           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13061           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13062         enddo
13063         utheta(i)=utheta_i/(ii-1)
13064 !
13065 ! Deviations from gamma angles
13066 !
13067         ugamma_i=0.0d0
13068         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13069           dgamma_i=pinorm(phi(j)-phiref(j))
13070 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13071           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13072           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13073 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13074         enddo
13075         ugamma(i)=ugamma_i/(ii-2)
13076 !
13077 ! Deviations from local SC geometry
13078 !
13079         uscdiff(i)=0.0d0
13080         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13081           dxx=xxtab(j)-xxref(j)
13082           dyy=yytab(j)-yyref(j)
13083           dzz=zztab(j)-zzref(j)
13084           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13085           do k=1,3
13086             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13087              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13088              (ii-1)
13089             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13090              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13091              (ii-1)
13092             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13093            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13094             /(ii-1)
13095           enddo
13096 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13097 !     &      xxref(j),yyref(j),zzref(j)
13098         enddo
13099         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13100 !        write (iout,*) i," uscdiff",uscdiff(i)
13101 !
13102 ! Put together deviations from local geometry
13103 !
13104         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13105           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13106 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13107 !     &   " uconst_back",uconst_back
13108         utheta(i)=dsqrt(utheta(i))
13109         ugamma(i)=dsqrt(ugamma(i))
13110         uscdiff(i)=dsqrt(uscdiff(i))
13111       enddo
13112       return
13113       end subroutine Econstr_back
13114 !-----------------------------------------------------------------------------
13115 ! energy_p_new-sep_barrier.F
13116 !-----------------------------------------------------------------------------
13117       real(kind=8) function sscale(r)
13118 !      include "COMMON.SPLITELE"
13119       real(kind=8) :: r,gamm
13120       if(r.lt.r_cut-rlamb) then
13121         sscale=1.0d0
13122       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13123         gamm=(r-(r_cut-rlamb))/rlamb
13124         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13125       else
13126         sscale=0d0
13127       endif
13128       return
13129       end function sscale
13130       real(kind=8) function sscale_grad(r)
13131 !      include "COMMON.SPLITELE"
13132       real(kind=8) :: r,gamm
13133       if(r.lt.r_cut-rlamb) then
13134         sscale_grad=0.0d0
13135       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13136         gamm=(r-(r_cut-rlamb))/rlamb
13137         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13138       else
13139         sscale_grad=0d0
13140       endif
13141       return
13142       end function sscale_grad
13143
13144 !!!!!!!!!! PBCSCALE
13145       real(kind=8) function sscale_ele(r)
13146 !      include "COMMON.SPLITELE"
13147       real(kind=8) :: r,gamm
13148       if(r.lt.r_cut_ele-rlamb_ele) then
13149         sscale_ele=1.0d0
13150       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13151         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13152         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13153       else
13154         sscale_ele=0d0
13155       endif
13156       return
13157       end function sscale_ele
13158
13159       real(kind=8)  function sscagrad_ele(r)
13160       real(kind=8) :: r,gamm
13161 !      include "COMMON.SPLITELE"
13162       if(r.lt.r_cut_ele-rlamb_ele) then
13163         sscagrad_ele=0.0d0
13164       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13165         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13166         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13167       else
13168         sscagrad_ele=0.0d0
13169       endif
13170       return
13171       end function sscagrad_ele
13172       real(kind=8) function sscalelip(r)
13173       real(kind=8) r,gamm
13174         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13175       return
13176       end function sscalelip
13177 !C-----------------------------------------------------------------------
13178       real(kind=8) function sscagradlip(r)
13179       real(kind=8) r,gamm
13180         sscagradlip=r*(6.0d0*r-6.0d0)
13181       return
13182       end function sscagradlip
13183
13184 !!!!!!!!!!!!!!!
13185 !-----------------------------------------------------------------------------
13186       subroutine elj_long(evdw)
13187 !
13188 ! This subroutine calculates the interaction energy of nonbonded side chains
13189 ! assuming the LJ potential of interaction.
13190 !
13191 !      implicit real*8 (a-h,o-z)
13192 !      include 'DIMENSIONS'
13193 !      include 'COMMON.GEO'
13194 !      include 'COMMON.VAR'
13195 !      include 'COMMON.LOCAL'
13196 !      include 'COMMON.CHAIN'
13197 !      include 'COMMON.DERIV'
13198 !      include 'COMMON.INTERACT'
13199 !      include 'COMMON.TORSION'
13200 !      include 'COMMON.SBRIDGE'
13201 !      include 'COMMON.NAMES'
13202 !      include 'COMMON.IOUNITS'
13203 !      include 'COMMON.CONTACTS'
13204       real(kind=8),parameter :: accur=1.0d-10
13205       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13206 !el local variables
13207       integer :: i,iint,j,k,itypi,itypi1,itypj
13208       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13209       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13210                       sslipj,ssgradlipj,aa,bb
13211 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13212       evdw=0.0D0
13213       do i=iatsc_s,iatsc_e
13214         itypi=itype(i,1)
13215         if (itypi.eq.ntyp1) cycle
13216         itypi1=itype(i+1,1)
13217         xi=c(1,nres+i)
13218         yi=c(2,nres+i)
13219         zi=c(3,nres+i)
13220         call to_box(xi,yi,zi)
13221         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13222 !
13223 ! Calculate SC interaction energy.
13224 !
13225         do iint=1,nint_gr(i)
13226 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13227 !d   &                  'iend=',iend(i,iint)
13228           do j=istart(i,iint),iend(i,iint)
13229             itypj=itype(j,1)
13230             if (itypj.eq.ntyp1) cycle
13231             xj=c(1,nres+j)-xi
13232             yj=c(2,nres+j)-yi
13233             zj=c(3,nres+j)-zi
13234             call to_box(xj,yj,zj)
13235             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13236             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13237              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13238             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13239              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13240             xj=boxshift(xj-xi,boxxsize)
13241             yj=boxshift(yj-yi,boxysize)
13242             zj=boxshift(zj-zi,boxzsize)
13243             rij=xj*xj+yj*yj+zj*zj
13244             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13245             if (sss.lt.1.0d0) then
13246               rrij=1.0D0/rij
13247               eps0ij=eps(itypi,itypj)
13248               fac=rrij**expon2
13249               e1=fac*fac*aa_aq(itypi,itypj)
13250               e2=fac*bb_aq(itypi,itypj)
13251               evdwij=e1+e2
13252               evdw=evdw+(1.0d0-sss)*evdwij
13253 !
13254 ! Calculate the components of the gradient in DC and X
13255 !
13256               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13257               gg(1)=xj*fac
13258               gg(2)=yj*fac
13259               gg(3)=zj*fac
13260               do k=1,3
13261                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13262                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13263                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13264                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13265               enddo
13266             endif
13267           enddo      ! j
13268         enddo        ! iint
13269       enddo          ! i
13270       do i=1,nct
13271         do j=1,3
13272           gvdwc(j,i)=expon*gvdwc(j,i)
13273           gvdwx(j,i)=expon*gvdwx(j,i)
13274         enddo
13275       enddo
13276 !******************************************************************************
13277 !
13278 !                              N O T E !!!
13279 !
13280 ! To save time, the factor of EXPON has been extracted from ALL components
13281 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13282 ! use!
13283 !
13284 !******************************************************************************
13285       return
13286       end subroutine elj_long
13287 !-----------------------------------------------------------------------------
13288       subroutine elj_short(evdw)
13289 !
13290 ! This subroutine calculates the interaction energy of nonbonded side chains
13291 ! assuming the LJ potential of interaction.
13292 !
13293 !      implicit real*8 (a-h,o-z)
13294 !      include 'DIMENSIONS'
13295 !      include 'COMMON.GEO'
13296 !      include 'COMMON.VAR'
13297 !      include 'COMMON.LOCAL'
13298 !      include 'COMMON.CHAIN'
13299 !      include 'COMMON.DERIV'
13300 !      include 'COMMON.INTERACT'
13301 !      include 'COMMON.TORSION'
13302 !      include 'COMMON.SBRIDGE'
13303 !      include 'COMMON.NAMES'
13304 !      include 'COMMON.IOUNITS'
13305 !      include 'COMMON.CONTACTS'
13306       real(kind=8),parameter :: accur=1.0d-10
13307       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13308 !el local variables
13309       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13310       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13311       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13312                       sslipj,ssgradlipj
13313 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13314       evdw=0.0D0
13315       do i=iatsc_s,iatsc_e
13316         itypi=itype(i,1)
13317         if (itypi.eq.ntyp1) cycle
13318         itypi1=itype(i+1,1)
13319         xi=c(1,nres+i)
13320         yi=c(2,nres+i)
13321         zi=c(3,nres+i)
13322         call to_box(xi,yi,zi)
13323         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13324 ! Change 12/1/95
13325         num_conti=0
13326 !
13327 ! Calculate SC interaction energy.
13328 !
13329         do iint=1,nint_gr(i)
13330 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13331 !d   &                  'iend=',iend(i,iint)
13332           do j=istart(i,iint),iend(i,iint)
13333             itypj=itype(j,1)
13334             if (itypj.eq.ntyp1) cycle
13335             xj=c(1,nres+j)-xi
13336             yj=c(2,nres+j)-yi
13337             zj=c(3,nres+j)-zi
13338 ! Change 12/1/95 to calculate four-body interactions
13339             rij=xj*xj+yj*yj+zj*zj
13340             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13341             if (sss.gt.0.0d0) then
13342               rrij=1.0D0/rij
13343               eps0ij=eps(itypi,itypj)
13344               fac=rrij**expon2
13345               e1=fac*fac*aa_aq(itypi,itypj)
13346               e2=fac*bb_aq(itypi,itypj)
13347               evdwij=e1+e2
13348               evdw=evdw+sss*evdwij
13349 !
13350 ! Calculate the components of the gradient in DC and X
13351 !
13352               fac=-rrij*(e1+evdwij)*sss
13353               gg(1)=xj*fac
13354               gg(2)=yj*fac
13355               gg(3)=zj*fac
13356               do k=1,3
13357                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13358                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13359                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13360                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13361               enddo
13362             endif
13363           enddo      ! j
13364         enddo        ! iint
13365       enddo          ! i
13366       do i=1,nct
13367         do j=1,3
13368           gvdwc(j,i)=expon*gvdwc(j,i)
13369           gvdwx(j,i)=expon*gvdwx(j,i)
13370         enddo
13371       enddo
13372 !******************************************************************************
13373 !
13374 !                              N O T E !!!
13375 !
13376 ! To save time, the factor of EXPON has been extracted from ALL components
13377 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13378 ! use!
13379 !
13380 !******************************************************************************
13381       return
13382       end subroutine elj_short
13383 !-----------------------------------------------------------------------------
13384       subroutine eljk_long(evdw)
13385 !
13386 ! This subroutine calculates the interaction energy of nonbonded side chains
13387 ! assuming the LJK potential of interaction.
13388 !
13389 !      implicit real*8 (a-h,o-z)
13390 !      include 'DIMENSIONS'
13391 !      include 'COMMON.GEO'
13392 !      include 'COMMON.VAR'
13393 !      include 'COMMON.LOCAL'
13394 !      include 'COMMON.CHAIN'
13395 !      include 'COMMON.DERIV'
13396 !      include 'COMMON.INTERACT'
13397 !      include 'COMMON.IOUNITS'
13398 !      include 'COMMON.NAMES'
13399       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13400       logical :: scheck
13401 !el local variables
13402       integer :: i,iint,j,k,itypi,itypi1,itypj
13403       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13404                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13405 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13406       evdw=0.0D0
13407       do i=iatsc_s,iatsc_e
13408         itypi=itype(i,1)
13409         if (itypi.eq.ntyp1) cycle
13410         itypi1=itype(i+1,1)
13411         xi=c(1,nres+i)
13412         yi=c(2,nres+i)
13413         zi=c(3,nres+i)
13414           call to_box(xi,yi,zi)
13415
13416 !
13417 ! Calculate SC interaction energy.
13418 !
13419         do iint=1,nint_gr(i)
13420           do j=istart(i,iint),iend(i,iint)
13421             itypj=itype(j,1)
13422             if (itypj.eq.ntyp1) cycle
13423             xj=c(1,nres+j)-xi
13424             yj=c(2,nres+j)-yi
13425             zj=c(3,nres+j)-zi
13426           call to_box(xj,yj,zj)
13427       xj=boxshift(xj-xi,boxxsize)
13428       yj=boxshift(yj-yi,boxysize)
13429       zj=boxshift(zj-zi,boxzsize)
13430
13431             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13432             fac_augm=rrij**expon
13433             e_augm=augm(itypi,itypj)*fac_augm
13434             r_inv_ij=dsqrt(rrij)
13435             rij=1.0D0/r_inv_ij
13436             sss=sscale(rij/sigma(itypi,itypj))
13437             if (sss.lt.1.0d0) then
13438               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13439               fac=r_shift_inv**expon
13440               e1=fac*fac*aa_aq(itypi,itypj)
13441               e2=fac*bb_aq(itypi,itypj)
13442               evdwij=e_augm+e1+e2
13443 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13444 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13445 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13446 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13447 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13448 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13449 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13450               evdw=evdw+(1.0d0-sss)*evdwij
13451 !
13452 ! Calculate the components of the gradient in DC and X
13453 !
13454               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13455               fac=fac*(1.0d0-sss)
13456               gg(1)=xj*fac
13457               gg(2)=yj*fac
13458               gg(3)=zj*fac
13459               do k=1,3
13460                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13461                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13462                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13463                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13464               enddo
13465             endif
13466           enddo      ! j
13467         enddo        ! iint
13468       enddo          ! i
13469       do i=1,nct
13470         do j=1,3
13471           gvdwc(j,i)=expon*gvdwc(j,i)
13472           gvdwx(j,i)=expon*gvdwx(j,i)
13473         enddo
13474       enddo
13475       return
13476       end subroutine eljk_long
13477 !-----------------------------------------------------------------------------
13478       subroutine eljk_short(evdw)
13479 !
13480 ! This subroutine calculates the interaction energy of nonbonded side chains
13481 ! assuming the LJK potential of interaction.
13482 !
13483 !      implicit real*8 (a-h,o-z)
13484 !      include 'DIMENSIONS'
13485 !      include 'COMMON.GEO'
13486 !      include 'COMMON.VAR'
13487 !      include 'COMMON.LOCAL'
13488 !      include 'COMMON.CHAIN'
13489 !      include 'COMMON.DERIV'
13490 !      include 'COMMON.INTERACT'
13491 !      include 'COMMON.IOUNITS'
13492 !      include 'COMMON.NAMES'
13493       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13494       logical :: scheck
13495 !el local variables
13496       integer :: i,iint,j,k,itypi,itypi1,itypj
13497       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13498                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
13499                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
13500 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13501       evdw=0.0D0
13502       do i=iatsc_s,iatsc_e
13503         itypi=itype(i,1)
13504         if (itypi.eq.ntyp1) cycle
13505         itypi1=itype(i+1,1)
13506         xi=c(1,nres+i)
13507         yi=c(2,nres+i)
13508         zi=c(3,nres+i)
13509         call to_box(xi,yi,zi)
13510         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13511 !
13512 ! Calculate SC interaction energy.
13513 !
13514         do iint=1,nint_gr(i)
13515           do j=istart(i,iint),iend(i,iint)
13516             itypj=itype(j,1)
13517             if (itypj.eq.ntyp1) cycle
13518             xj=c(1,nres+j)-xi
13519             yj=c(2,nres+j)-yi
13520             zj=c(3,nres+j)-zi
13521             call to_box(xj,yj,zj)
13522             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13523             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13524              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13525             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13526              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13527             xj=boxshift(xj-xi,boxxsize)
13528             yj=boxshift(yj-yi,boxysize)
13529             zj=boxshift(zj-zi,boxzsize)
13530             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13531             fac_augm=rrij**expon
13532             e_augm=augm(itypi,itypj)*fac_augm
13533             r_inv_ij=dsqrt(rrij)
13534             rij=1.0D0/r_inv_ij
13535             sss=sscale(rij/sigma(itypi,itypj))
13536             if (sss.gt.0.0d0) then
13537               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13538               fac=r_shift_inv**expon
13539               e1=fac*fac*aa_aq(itypi,itypj)
13540               e2=fac*bb_aq(itypi,itypj)
13541               evdwij=e_augm+e1+e2
13542 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13543 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13544 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13545 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13546 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13547 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13548 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13549               evdw=evdw+sss*evdwij
13550 !
13551 ! Calculate the components of the gradient in DC and X
13552 !
13553               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13554               fac=fac*sss
13555               gg(1)=xj*fac
13556               gg(2)=yj*fac
13557               gg(3)=zj*fac
13558               do k=1,3
13559                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13560                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13561                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13562                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13563               enddo
13564             endif
13565           enddo      ! j
13566         enddo        ! iint
13567       enddo          ! i
13568       do i=1,nct
13569         do j=1,3
13570           gvdwc(j,i)=expon*gvdwc(j,i)
13571           gvdwx(j,i)=expon*gvdwx(j,i)
13572         enddo
13573       enddo
13574       return
13575       end subroutine eljk_short
13576 !-----------------------------------------------------------------------------
13577        subroutine ebp_long(evdw)
13578 ! This subroutine calculates the interaction energy of nonbonded side chains
13579 ! assuming the Berne-Pechukas potential of interaction.
13580 !
13581        use calc_data
13582 !      implicit real*8 (a-h,o-z)
13583 !      include 'DIMENSIONS'
13584 !      include 'COMMON.GEO'
13585 !      include 'COMMON.VAR'
13586 !      include 'COMMON.LOCAL'
13587 !      include 'COMMON.CHAIN'
13588 !      include 'COMMON.DERIV'
13589 !      include 'COMMON.NAMES'
13590 !      include 'COMMON.INTERACT'
13591 !      include 'COMMON.IOUNITS'
13592 !      include 'COMMON.CALC'
13593        use comm_srutu
13594 !el      integer :: icall
13595 !el      common /srutu/ icall
13596 !     double precision rrsave(maxdim)
13597         logical :: lprn
13598 !el local variables
13599         integer :: iint,itypi,itypi1,itypj
13600         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
13601                         sslipj,ssgradlipj,aa,bb
13602         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13603         evdw=0.0D0
13604 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13605         evdw=0.0D0
13606 !     if (icall.eq.0) then
13607 !       lprn=.true.
13608 !     else
13609       lprn=.false.
13610 !     endif
13611 !el      ind=0
13612       do i=iatsc_s,iatsc_e
13613       itypi=itype(i,1)
13614       if (itypi.eq.ntyp1) cycle
13615       itypi1=itype(i+1,1)
13616       xi=c(1,nres+i)
13617       yi=c(2,nres+i)
13618       zi=c(3,nres+i)
13619         call to_box(xi,yi,zi)
13620         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13621       dxi=dc_norm(1,nres+i)
13622       dyi=dc_norm(2,nres+i)
13623       dzi=dc_norm(3,nres+i)
13624 !        dsci_inv=dsc_inv(itypi)
13625       dsci_inv=vbld_inv(i+nres)
13626 !
13627 ! Calculate SC interaction energy.
13628 !
13629       do iint=1,nint_gr(i)
13630       do j=istart(i,iint),iend(i,iint)
13631 !el            ind=ind+1
13632       itypj=itype(j,1)
13633       if (itypj.eq.ntyp1) cycle
13634 !            dscj_inv=dsc_inv(itypj)
13635       dscj_inv=vbld_inv(j+nres)
13636 chi1=chi(itypi,itypj)
13637 chi2=chi(itypj,itypi)
13638 chi12=chi1*chi2
13639 chip1=chip(itypi)
13640       alf1=alp(itypi)
13641       alf2=alp(itypj)
13642       alf12=0.5D0*(alf1+alf2)
13643         xj=c(1,nres+j)-xi
13644         yj=c(2,nres+j)-yi
13645         zj=c(3,nres+j)-zi
13646             call to_box(xj,yj,zj)
13647             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13648             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13649              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13650             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13651              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13652             xj=boxshift(xj-xi,boxxsize)
13653             yj=boxshift(yj-yi,boxysize)
13654             zj=boxshift(zj-zi,boxzsize)
13655         dxj=dc_norm(1,nres+j)
13656         dyj=dc_norm(2,nres+j)
13657         dzj=dc_norm(3,nres+j)
13658         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13659         rij=dsqrt(rrij)
13660       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13661
13662         if (sss.lt.1.0d0) then
13663
13664         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13665         call sc_angular
13666         ! Calculate whole angle-dependent part of epsilon and contributions
13667         ! to its derivatives
13668         fac=(rrij*sigsq)**expon2
13669         e1=fac*fac*aa_aq(itypi,itypj)
13670         e2=fac*bb_aq(itypi,itypj)
13671       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13672         eps2der=evdwij*eps3rt
13673         eps3der=evdwij*eps2rt
13674         evdwij=evdwij*eps2rt*eps3rt
13675       evdw=evdw+evdwij*(1.0d0-sss)
13676         if (lprn) then
13677         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13678       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13679         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13680         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13681         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13682         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13683         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13684         !d     &          evdwij
13685         endif
13686         ! Calculate gradient components.
13687         e1=e1*eps1*eps2rt**2*eps3rt**2
13688       fac=-expon*(e1+evdwij)
13689         sigder=fac/sigsq
13690         fac=rrij*fac
13691         ! Calculate radial part of the gradient
13692         gg(1)=xj*fac
13693         gg(2)=yj*fac
13694         gg(3)=zj*fac
13695         ! Calculate the angular part of the gradient and sum add the contributions
13696         ! to the appropriate components of the Cartesian gradient.
13697       call sc_grad_scale(1.0d0-sss)
13698         endif
13699         enddo      ! j
13700         enddo        ! iint
13701         enddo          ! i
13702         !     stop
13703         return
13704         end subroutine ebp_long
13705         !-----------------------------------------------------------------------------
13706       subroutine ebp_short(evdw)
13707         !
13708         ! This subroutine calculates the interaction energy of nonbonded side chains
13709         ! assuming the Berne-Pechukas potential of interaction.
13710         !
13711         use calc_data
13712 !      implicit real*8 (a-h,o-z)
13713         !      include 'DIMENSIONS'
13714         !      include 'COMMON.GEO'
13715         !      include 'COMMON.VAR'
13716         !      include 'COMMON.LOCAL'
13717         !      include 'COMMON.CHAIN'
13718         !      include 'COMMON.DERIV'
13719         !      include 'COMMON.NAMES'
13720         !      include 'COMMON.INTERACT'
13721         !      include 'COMMON.IOUNITS'
13722         !      include 'COMMON.CALC'
13723         use comm_srutu
13724         !el      integer :: icall
13725         !el      common /srutu/ icall
13726 !     double precision rrsave(maxdim)
13727         logical :: lprn
13728         !el local variables
13729         integer :: iint,itypi,itypi1,itypj
13730         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13731         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
13732         sslipi,ssgradlipi,sslipj,ssgradlipj
13733         evdw=0.0D0
13734         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13735         evdw=0.0D0
13736         !     if (icall.eq.0) then
13737         !       lprn=.true.
13738         !     else
13739         lprn=.false.
13740         !     endif
13741         !el      ind=0
13742         do i=iatsc_s,iatsc_e
13743       itypi=itype(i,1)
13744         if (itypi.eq.ntyp1) cycle
13745         itypi1=itype(i+1,1)
13746         xi=c(1,nres+i)
13747         yi=c(2,nres+i)
13748         zi=c(3,nres+i)
13749         call to_box(xi,yi,zi)
13750       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13751
13752         dxi=dc_norm(1,nres+i)
13753         dyi=dc_norm(2,nres+i)
13754         dzi=dc_norm(3,nres+i)
13755         !        dsci_inv=dsc_inv(itypi)
13756       dsci_inv=vbld_inv(i+nres)
13757         !
13758         ! Calculate SC interaction energy.
13759         !
13760         do iint=1,nint_gr(i)
13761       do j=istart(i,iint),iend(i,iint)
13762         !el            ind=ind+1
13763       itypj=itype(j,1)
13764         if (itypj.eq.ntyp1) cycle
13765         !            dscj_inv=dsc_inv(itypj)
13766         dscj_inv=vbld_inv(j+nres)
13767         chi1=chi(itypi,itypj)
13768       chi2=chi(itypj,itypi)
13769         chi12=chi1*chi2
13770         chip1=chip(itypi)
13771       chip2=chip(itypj)
13772         chip12=chip1*chip2
13773         alf1=alp(itypi)
13774         alf2=alp(itypj)
13775       alf12=0.5D0*(alf1+alf2)
13776         xj=c(1,nres+j)-xi
13777         yj=c(2,nres+j)-yi
13778         zj=c(3,nres+j)-zi
13779         call to_box(xj,yj,zj)
13780       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13781         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13782         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13783         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13784              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13785             xj=boxshift(xj-xi,boxxsize)
13786             yj=boxshift(yj-yi,boxysize)
13787             zj=boxshift(zj-zi,boxzsize)
13788             dxj=dc_norm(1,nres+j)
13789             dyj=dc_norm(2,nres+j)
13790             dzj=dc_norm(3,nres+j)
13791             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13792             rij=dsqrt(rrij)
13793             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13794
13795             if (sss.gt.0.0d0) then
13796
13797 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13798               call sc_angular
13799 ! Calculate whole angle-dependent part of epsilon and contributions
13800 ! to its derivatives
13801               fac=(rrij*sigsq)**expon2
13802               e1=fac*fac*aa_aq(itypi,itypj)
13803               e2=fac*bb_aq(itypi,itypj)
13804               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13805               eps2der=evdwij*eps3rt
13806               eps3der=evdwij*eps2rt
13807               evdwij=evdwij*eps2rt*eps3rt
13808               evdw=evdw+evdwij*sss
13809               if (lprn) then
13810               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13811               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13812 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13813 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13814 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13815 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13816 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13817 !d     &          evdwij
13818               endif
13819 ! Calculate gradient components.
13820               e1=e1*eps1*eps2rt**2*eps3rt**2
13821               fac=-expon*(e1+evdwij)
13822               sigder=fac/sigsq
13823               fac=rrij*fac
13824 ! Calculate radial part of the gradient
13825               gg(1)=xj*fac
13826               gg(2)=yj*fac
13827               gg(3)=zj*fac
13828 ! Calculate the angular part of the gradient and sum add the contributions
13829 ! to the appropriate components of the Cartesian gradient.
13830               call sc_grad_scale(sss)
13831             endif
13832           enddo      ! j
13833         enddo        ! iint
13834       enddo          ! i
13835 !     stop
13836       return
13837       end subroutine ebp_short
13838 !-----------------------------------------------------------------------------
13839       subroutine egb_long(evdw)
13840 !
13841 ! This subroutine calculates the interaction energy of nonbonded side chains
13842 ! assuming the Gay-Berne potential of interaction.
13843 !
13844       use calc_data
13845 !      implicit real*8 (a-h,o-z)
13846 !      include 'DIMENSIONS'
13847 !      include 'COMMON.GEO'
13848 !      include 'COMMON.VAR'
13849 !      include 'COMMON.LOCAL'
13850 !      include 'COMMON.CHAIN'
13851 !      include 'COMMON.DERIV'
13852 !      include 'COMMON.NAMES'
13853 !      include 'COMMON.INTERACT'
13854 !      include 'COMMON.IOUNITS'
13855 !      include 'COMMON.CALC'
13856 !      include 'COMMON.CONTROL'
13857       logical :: lprn
13858 !el local variables
13859       integer :: iint,itypi,itypi1,itypj,subchap
13860       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13861       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13862       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13863                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13864                     ssgradlipi,ssgradlipj
13865
13866
13867       evdw=0.0D0
13868 !cccc      energy_dec=.false.
13869 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13870       evdw=0.0D0
13871       lprn=.false.
13872 !     if (icall.eq.0) lprn=.false.
13873 !el      ind=0
13874       do i=iatsc_s,iatsc_e
13875         itypi=itype(i,1)
13876         if (itypi.eq.ntyp1) cycle
13877         itypi1=itype(i+1,1)
13878         xi=c(1,nres+i)
13879         yi=c(2,nres+i)
13880         zi=c(3,nres+i)
13881         call to_box(xi,yi,zi)
13882         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13883         dxi=dc_norm(1,nres+i)
13884         dyi=dc_norm(2,nres+i)
13885         dzi=dc_norm(3,nres+i)
13886 !        dsci_inv=dsc_inv(itypi)
13887         dsci_inv=vbld_inv(i+nres)
13888 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13889 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13890 !
13891 ! Calculate SC interaction energy.
13892 !
13893         do iint=1,nint_gr(i)
13894           do j=istart(i,iint),iend(i,iint)
13895             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13896 !              call dyn_ssbond_ene(i,j,evdwij)
13897 !              evdw=evdw+evdwij
13898 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13899 !                              'evdw',i,j,evdwij,' ss'
13900 !              if (energy_dec) write (iout,*) &
13901 !                              'evdw',i,j,evdwij,' ss'
13902 !             do k=j+1,iend(i,iint)
13903 !C search over all next residues
13904 !              if (dyn_ss_mask(k)) then
13905 !C check if they are cysteins
13906 !C              write(iout,*) 'k=',k
13907
13908 !c              write(iout,*) "PRZED TRI", evdwij
13909 !               evdwij_przed_tri=evdwij
13910 !              call triple_ssbond_ene(i,j,k,evdwij)
13911 !c               if(evdwij_przed_tri.ne.evdwij) then
13912 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13913 !c               endif
13914
13915 !c              write(iout,*) "PO TRI", evdwij
13916 !C call the energy function that removes the artifical triple disulfide
13917 !C bond the soubroutine is located in ssMD.F
13918 !              evdw=evdw+evdwij
13919               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13920                             'evdw',i,j,evdwij,'tss'
13921 !              endif!dyn_ss_mask(k)
13922 !             enddo! k
13923
13924             ELSE
13925 !el            ind=ind+1
13926             itypj=itype(j,1)
13927             if (itypj.eq.ntyp1) cycle
13928 !            dscj_inv=dsc_inv(itypj)
13929             dscj_inv=vbld_inv(j+nres)
13930 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13931 !     &       1.0d0/vbld(j+nres)
13932 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13933             sig0ij=sigma(itypi,itypj)
13934             chi1=chi(itypi,itypj)
13935             chi2=chi(itypj,itypi)
13936             chi12=chi1*chi2
13937             chip1=chip(itypi)
13938             chip2=chip(itypj)
13939             chip12=chip1*chip2
13940             alf1=alp(itypi)
13941             alf2=alp(itypj)
13942             alf12=0.5D0*(alf1+alf2)
13943             xj=c(1,nres+j)
13944             yj=c(2,nres+j)
13945             zj=c(3,nres+j)
13946 ! Searching for nearest neighbour
13947             call to_box(xj,yj,zj)
13948             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13949             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13950              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13951             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13952              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13953             xj=boxshift(xj-xi,boxxsize)
13954             yj=boxshift(yj-yi,boxysize)
13955             zj=boxshift(zj-zi,boxzsize)
13956             dxj=dc_norm(1,nres+j)
13957             dyj=dc_norm(2,nres+j)
13958             dzj=dc_norm(3,nres+j)
13959             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13960             rij=dsqrt(rrij)
13961             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13962             sss_ele_cut=sscale_ele(1.0d0/(rij))
13963             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
13964             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13965             if (sss_ele_cut.le.0.0) cycle
13966             if (sss.lt.1.0d0) then
13967
13968 ! Calculate angle-dependent terms of energy and contributions to their
13969 ! derivatives.
13970               call sc_angular
13971               sigsq=1.0D0/sigsq
13972               sig=sig0ij*dsqrt(sigsq)
13973               rij_shift=1.0D0/rij-sig+sig0ij
13974 ! for diagnostics; uncomment
13975 !              rij_shift=1.2*sig0ij
13976 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13977               if (rij_shift.le.0.0D0) then
13978                 evdw=1.0D20
13979 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13980 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13981 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13982                 return
13983               endif
13984               sigder=-sig*sigsq
13985 !---------------------------------------------------------------
13986               rij_shift=1.0D0/rij_shift
13987               fac=rij_shift**expon
13988               e1=fac*fac*aa
13989               e2=fac*bb
13990               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13991               eps2der=evdwij*eps3rt
13992               eps3der=evdwij*eps2rt
13993 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13994 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13995               evdwij=evdwij*eps2rt*eps3rt
13996               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13997               if (lprn) then
13998               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13999               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14000               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14001                 restyp(itypi,1),i,restyp(itypj,1),j,&
14002                 epsi,sigm,chi1,chi2,chip1,chip2,&
14003                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14004                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14005                 evdwij
14006               endif
14007
14008               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14009                               'evdw',i,j,evdwij
14010 !              if (energy_dec) write (iout,*) &
14011 !                              'evdw',i,j,evdwij,"egb_long"
14012
14013 ! Calculate gradient components.
14014               e1=e1*eps1*eps2rt**2*eps3rt**2
14015               fac=-expon*(e1+evdwij)*rij_shift
14016               sigder=fac*sigder
14017               fac=rij*fac
14018               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14019               *rij-sss_grad/(1.0-sss)*rij  &
14020             /sigmaii(itypi,itypj))
14021 !              fac=0.0d0
14022 ! Calculate the radial part of the gradient
14023               gg(1)=xj*fac
14024               gg(2)=yj*fac
14025               gg(3)=zj*fac
14026 ! Calculate angular part of the gradient.
14027               call sc_grad_scale(1.0d0-sss)
14028             ENDIF    !mask_dyn_ss
14029             endif
14030           enddo      ! j
14031         enddo        ! iint
14032       enddo          ! i
14033 !      write (iout,*) "Number of loop steps in EGB:",ind
14034 !ccc      energy_dec=.false.
14035       return
14036       end subroutine egb_long
14037 !-----------------------------------------------------------------------------
14038       subroutine egb_short(evdw)
14039 !
14040 ! This subroutine calculates the interaction energy of nonbonded side chains
14041 ! assuming the Gay-Berne potential of interaction.
14042 !
14043       use calc_data
14044 !      implicit real*8 (a-h,o-z)
14045 !      include 'DIMENSIONS'
14046 !      include 'COMMON.GEO'
14047 !      include 'COMMON.VAR'
14048 !      include 'COMMON.LOCAL'
14049 !      include 'COMMON.CHAIN'
14050 !      include 'COMMON.DERIV'
14051 !      include 'COMMON.NAMES'
14052 !      include 'COMMON.INTERACT'
14053 !      include 'COMMON.IOUNITS'
14054 !      include 'COMMON.CALC'
14055 !      include 'COMMON.CONTROL'
14056       logical :: lprn
14057 !el local variables
14058       integer :: iint,itypi,itypi1,itypj,subchap
14059       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14060       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14061       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14062                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14063                     ssgradlipi,ssgradlipj
14064       evdw=0.0D0
14065 !cccc      energy_dec=.false.
14066 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14067       evdw=0.0D0
14068       lprn=.false.
14069 !     if (icall.eq.0) lprn=.false.
14070 !el      ind=0
14071       do i=iatsc_s,iatsc_e
14072         itypi=itype(i,1)
14073         if (itypi.eq.ntyp1) cycle
14074         itypi1=itype(i+1,1)
14075         xi=c(1,nres+i)
14076         yi=c(2,nres+i)
14077         zi=c(3,nres+i)
14078         call to_box(xi,yi,zi)
14079         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14080
14081         dxi=dc_norm(1,nres+i)
14082         dyi=dc_norm(2,nres+i)
14083         dzi=dc_norm(3,nres+i)
14084 !        dsci_inv=dsc_inv(itypi)
14085         dsci_inv=vbld_inv(i+nres)
14086
14087         dxi=dc_norm(1,nres+i)
14088         dyi=dc_norm(2,nres+i)
14089         dzi=dc_norm(3,nres+i)
14090 !        dsci_inv=dsc_inv(itypi)
14091         dsci_inv=vbld_inv(i+nres)
14092         do iint=1,nint_gr(i)
14093           do j=istart(i,iint),iend(i,iint)
14094             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14095               call dyn_ssbond_ene(i,j,evdwij)
14096               evdw=evdw+evdwij
14097               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14098                               'evdw',i,j,evdwij,' ss'
14099              do k=j+1,iend(i,iint)
14100 !C search over all next residues
14101               if (dyn_ss_mask(k)) then
14102 !C check if they are cysteins
14103 !C              write(iout,*) 'k=',k
14104
14105 !c              write(iout,*) "PRZED TRI", evdwij
14106 !               evdwij_przed_tri=evdwij
14107               call triple_ssbond_ene(i,j,k,evdwij)
14108 !c               if(evdwij_przed_tri.ne.evdwij) then
14109 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14110 !c               endif
14111
14112 !c              write(iout,*) "PO TRI", evdwij
14113 !C call the energy function that removes the artifical triple disulfide
14114 !C bond the soubroutine is located in ssMD.F
14115               evdw=evdw+evdwij
14116               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14117                             'evdw',i,j,evdwij,'tss'
14118               endif!dyn_ss_mask(k)
14119              enddo! k
14120             ELSE
14121
14122 !          typj=itype(j,1)
14123             if (itypj.eq.ntyp1) cycle
14124 !            dscj_inv=dsc_inv(itypj)
14125             dscj_inv=vbld_inv(j+nres)
14126             dscj_inv=dsc_inv(itypj)
14127 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14128 !     &       1.0d0/vbld(j+nres)
14129 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14130             sig0ij=sigma(itypi,itypj)
14131             chi1=chi(itypi,itypj)
14132             chi2=chi(itypj,itypi)
14133             chi12=chi1*chi2
14134             chip1=chip(itypi)
14135             chip2=chip(itypj)
14136             chip12=chip1*chip2
14137             alf1=alp(itypi)
14138             alf2=alp(itypj)
14139             alf12=0.5D0*(alf1+alf2)
14140 !            xj=c(1,nres+j)-xi
14141 !            yj=c(2,nres+j)-yi
14142 !            zj=c(3,nres+j)-zi
14143             xj=c(1,nres+j)
14144             yj=c(2,nres+j)
14145             zj=c(3,nres+j)
14146 ! Searching for nearest neighbour
14147             call to_box(xj,yj,zj)
14148             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14149             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14150              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14151             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14152              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14153             xj=boxshift(xj-xi,boxxsize)
14154             yj=boxshift(yj-yi,boxysize)
14155             zj=boxshift(zj-zi,boxzsize)
14156             dxj=dc_norm(1,nres+j)
14157             dyj=dc_norm(2,nres+j)
14158             dzj=dc_norm(3,nres+j)
14159             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14160             rij=dsqrt(rrij)
14161             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14162             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14163             sss_ele_cut=sscale_ele(1.0d0/(rij))
14164             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14165             if (sss_ele_cut.le.0.0) cycle
14166
14167             if (sss.gt.0.0d0) then
14168
14169 ! Calculate angle-dependent terms of energy and contributions to their
14170 ! derivatives.
14171               call sc_angular
14172               sigsq=1.0D0/sigsq
14173               sig=sig0ij*dsqrt(sigsq)
14174               rij_shift=1.0D0/rij-sig+sig0ij
14175 ! for diagnostics; uncomment
14176 !              rij_shift=1.2*sig0ij
14177 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14178               if (rij_shift.le.0.0D0) then
14179                 evdw=1.0D20
14180 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14181 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14182 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14183                 return
14184               endif
14185               sigder=-sig*sigsq
14186 !---------------------------------------------------------------
14187               rij_shift=1.0D0/rij_shift
14188               fac=rij_shift**expon
14189               e1=fac*fac*aa
14190               e2=fac*bb
14191               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14192               eps2der=evdwij*eps3rt
14193               eps3der=evdwij*eps2rt
14194 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14195 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14196               evdwij=evdwij*eps2rt*eps3rt
14197               evdw=evdw+evdwij*sss*sss_ele_cut
14198               if (lprn) then
14199               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14200               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14201               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14202                 restyp(itypi,1),i,restyp(itypj,1),j,&
14203                 epsi,sigm,chi1,chi2,chip1,chip2,&
14204                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14205                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14206                 evdwij
14207               endif
14208
14209               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14210                               'evdw',i,j,evdwij
14211 !              if (energy_dec) write (iout,*) &
14212 !                              'evdw',i,j,evdwij,"egb_short"
14213
14214 ! Calculate gradient components.
14215               e1=e1*eps1*eps2rt**2*eps3rt**2
14216               fac=-expon*(e1+evdwij)*rij_shift
14217               sigder=fac*sigder
14218               fac=rij*fac
14219               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14220             *rij+sss_grad/sss*rij  &
14221             /sigmaii(itypi,itypj))
14222
14223 !              fac=0.0d0
14224 ! Calculate the radial part of the gradient
14225               gg(1)=xj*fac
14226               gg(2)=yj*fac
14227               gg(3)=zj*fac
14228 ! Calculate angular part of the gradient.
14229               call sc_grad_scale(sss)
14230             endif
14231           ENDIF !mask_dyn_ss
14232           enddo      ! j
14233         enddo        ! iint
14234       enddo          ! i
14235 !      write (iout,*) "Number of loop steps in EGB:",ind
14236 !ccc      energy_dec=.false.
14237       return
14238       end subroutine egb_short
14239 !-----------------------------------------------------------------------------
14240       subroutine egbv_long(evdw)
14241 !
14242 ! This subroutine calculates the interaction energy of nonbonded side chains
14243 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14244 !
14245       use calc_data
14246 !      implicit real*8 (a-h,o-z)
14247 !      include 'DIMENSIONS'
14248 !      include 'COMMON.GEO'
14249 !      include 'COMMON.VAR'
14250 !      include 'COMMON.LOCAL'
14251 !      include 'COMMON.CHAIN'
14252 !      include 'COMMON.DERIV'
14253 !      include 'COMMON.NAMES'
14254 !      include 'COMMON.INTERACT'
14255 !      include 'COMMON.IOUNITS'
14256 !      include 'COMMON.CALC'
14257       use comm_srutu
14258 !el      integer :: icall
14259 !el      common /srutu/ icall
14260       logical :: lprn
14261 !el local variables
14262       integer :: iint,itypi,itypi1,itypj
14263       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14264                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14265       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14266       evdw=0.0D0
14267 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14268       evdw=0.0D0
14269       lprn=.false.
14270 !     if (icall.eq.0) lprn=.true.
14271 !el      ind=0
14272       do i=iatsc_s,iatsc_e
14273         itypi=itype(i,1)
14274         if (itypi.eq.ntyp1) cycle
14275         itypi1=itype(i+1,1)
14276         xi=c(1,nres+i)
14277         yi=c(2,nres+i)
14278         zi=c(3,nres+i)
14279         call to_box(xi,yi,zi)
14280         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14281         dxi=dc_norm(1,nres+i)
14282         dyi=dc_norm(2,nres+i)
14283         dzi=dc_norm(3,nres+i)
14284
14285 !        dsci_inv=dsc_inv(itypi)
14286         dsci_inv=vbld_inv(i+nres)
14287 !
14288 ! Calculate SC interaction energy.
14289 !
14290         do iint=1,nint_gr(i)
14291           do j=istart(i,iint),iend(i,iint)
14292 !el            ind=ind+1
14293             itypj=itype(j,1)
14294             if (itypj.eq.ntyp1) cycle
14295 !            dscj_inv=dsc_inv(itypj)
14296             dscj_inv=vbld_inv(j+nres)
14297             sig0ij=sigma(itypi,itypj)
14298             r0ij=r0(itypi,itypj)
14299             chi1=chi(itypi,itypj)
14300             chi2=chi(itypj,itypi)
14301             chi12=chi1*chi2
14302             chip1=chip(itypi)
14303             chip2=chip(itypj)
14304             chip12=chip1*chip2
14305             alf1=alp(itypi)
14306             alf2=alp(itypj)
14307             alf12=0.5D0*(alf1+alf2)
14308             xj=c(1,nres+j)-xi
14309             yj=c(2,nres+j)-yi
14310             zj=c(3,nres+j)-zi
14311             call to_box(xj,yj,zj)
14312             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14313             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14314             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14315             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14316             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14317             xj=boxshift(xj-xi,boxxsize)
14318             yj=boxshift(yj-yi,boxysize)
14319             zj=boxshift(zj-zi,boxzsize)
14320             dxj=dc_norm(1,nres+j)
14321             dyj=dc_norm(2,nres+j)
14322             dzj=dc_norm(3,nres+j)
14323             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14324             rij=dsqrt(rrij)
14325
14326             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14327
14328             if (sss.lt.1.0d0) then
14329
14330 ! Calculate angle-dependent terms of energy and contributions to their
14331 ! derivatives.
14332               call sc_angular
14333               sigsq=1.0D0/sigsq
14334               sig=sig0ij*dsqrt(sigsq)
14335               rij_shift=1.0D0/rij-sig+r0ij
14336 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14337               if (rij_shift.le.0.0D0) then
14338                 evdw=1.0D20
14339                 return
14340               endif
14341               sigder=-sig*sigsq
14342 !---------------------------------------------------------------
14343               rij_shift=1.0D0/rij_shift
14344               fac=rij_shift**expon
14345               e1=fac*fac*aa_aq(itypi,itypj)
14346               e2=fac*bb_aq(itypi,itypj)
14347               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14348               eps2der=evdwij*eps3rt
14349               eps3der=evdwij*eps2rt
14350               fac_augm=rrij**expon
14351               e_augm=augm(itypi,itypj)*fac_augm
14352               evdwij=evdwij*eps2rt*eps3rt
14353               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14354               if (lprn) then
14355               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14356               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14357               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14358                 restyp(itypi,1),i,restyp(itypj,1),j,&
14359                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14360                 chi1,chi2,chip1,chip2,&
14361                 eps1,eps2rt**2,eps3rt**2,&
14362                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14363                 evdwij+e_augm
14364               endif
14365 ! Calculate gradient components.
14366               e1=e1*eps1*eps2rt**2*eps3rt**2
14367               fac=-expon*(e1+evdwij)*rij_shift
14368               sigder=fac*sigder
14369               fac=rij*fac-2*expon*rrij*e_augm
14370 ! Calculate the radial part of the gradient
14371               gg(1)=xj*fac
14372               gg(2)=yj*fac
14373               gg(3)=zj*fac
14374 ! Calculate angular part of the gradient.
14375               call sc_grad_scale(1.0d0-sss)
14376             endif
14377           enddo      ! j
14378         enddo        ! iint
14379       enddo          ! i
14380       end subroutine egbv_long
14381 !-----------------------------------------------------------------------------
14382       subroutine egbv_short(evdw)
14383 !
14384 ! This subroutine calculates the interaction energy of nonbonded side chains
14385 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14386 !
14387       use calc_data
14388 !      implicit real*8 (a-h,o-z)
14389 !      include 'DIMENSIONS'
14390 !      include 'COMMON.GEO'
14391 !      include 'COMMON.VAR'
14392 !      include 'COMMON.LOCAL'
14393 !      include 'COMMON.CHAIN'
14394 !      include 'COMMON.DERIV'
14395 !      include 'COMMON.NAMES'
14396 !      include 'COMMON.INTERACT'
14397 !      include 'COMMON.IOUNITS'
14398 !      include 'COMMON.CALC'
14399       use comm_srutu
14400 !el      integer :: icall
14401 !el      common /srutu/ icall
14402       logical :: lprn
14403 !el local variables
14404       integer :: iint,itypi,itypi1,itypj
14405       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
14406                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
14407       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14408       evdw=0.0D0
14409 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14410       evdw=0.0D0
14411       lprn=.false.
14412 !     if (icall.eq.0) lprn=.true.
14413 !el      ind=0
14414       do i=iatsc_s,iatsc_e
14415         itypi=itype(i,1)
14416         if (itypi.eq.ntyp1) cycle
14417         itypi1=itype(i+1,1)
14418         xi=c(1,nres+i)
14419         yi=c(2,nres+i)
14420         zi=c(3,nres+i)
14421         dxi=dc_norm(1,nres+i)
14422         dyi=dc_norm(2,nres+i)
14423         dzi=dc_norm(3,nres+i)
14424         call to_box(xi,yi,zi)
14425         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14426 !        dsci_inv=dsc_inv(itypi)
14427         dsci_inv=vbld_inv(i+nres)
14428 !
14429 ! Calculate SC interaction energy.
14430 !
14431         do iint=1,nint_gr(i)
14432           do j=istart(i,iint),iend(i,iint)
14433 !el            ind=ind+1
14434             itypj=itype(j,1)
14435             if (itypj.eq.ntyp1) cycle
14436 !            dscj_inv=dsc_inv(itypj)
14437             dscj_inv=vbld_inv(j+nres)
14438             sig0ij=sigma(itypi,itypj)
14439             r0ij=r0(itypi,itypj)
14440             chi1=chi(itypi,itypj)
14441             chi2=chi(itypj,itypi)
14442             chi12=chi1*chi2
14443             chip1=chip(itypi)
14444             chip2=chip(itypj)
14445             chip12=chip1*chip2
14446             alf1=alp(itypi)
14447             alf2=alp(itypj)
14448             alf12=0.5D0*(alf1+alf2)
14449             xj=c(1,nres+j)-xi
14450             yj=c(2,nres+j)-yi
14451             zj=c(3,nres+j)-zi
14452             call to_box(xj,yj,zj)
14453             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14454             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14455             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14456             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14457             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14458             xj=boxshift(xj-xi,boxxsize)
14459             yj=boxshift(yj-yi,boxysize)
14460             zj=boxshift(zj-zi,boxzsize)
14461             dxj=dc_norm(1,nres+j)
14462             dyj=dc_norm(2,nres+j)
14463             dzj=dc_norm(3,nres+j)
14464             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14465             rij=dsqrt(rrij)
14466
14467             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14468
14469             if (sss.gt.0.0d0) then
14470
14471 ! Calculate angle-dependent terms of energy and contributions to their
14472 ! derivatives.
14473               call sc_angular
14474               sigsq=1.0D0/sigsq
14475               sig=sig0ij*dsqrt(sigsq)
14476               rij_shift=1.0D0/rij-sig+r0ij
14477 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14478               if (rij_shift.le.0.0D0) then
14479                 evdw=1.0D20
14480                 return
14481               endif
14482               sigder=-sig*sigsq
14483 !---------------------------------------------------------------
14484               rij_shift=1.0D0/rij_shift
14485               fac=rij_shift**expon
14486               e1=fac*fac*aa_aq(itypi,itypj)
14487               e2=fac*bb_aq(itypi,itypj)
14488               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14489               eps2der=evdwij*eps3rt
14490               eps3der=evdwij*eps2rt
14491               fac_augm=rrij**expon
14492               e_augm=augm(itypi,itypj)*fac_augm
14493               evdwij=evdwij*eps2rt*eps3rt
14494               evdw=evdw+(evdwij+e_augm)*sss
14495               if (lprn) then
14496               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14497               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14498               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14499                 restyp(itypi,1),i,restyp(itypj,1),j,&
14500                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14501                 chi1,chi2,chip1,chip2,&
14502                 eps1,eps2rt**2,eps3rt**2,&
14503                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14504                 evdwij+e_augm
14505               endif
14506 ! Calculate gradient components.
14507               e1=e1*eps1*eps2rt**2*eps3rt**2
14508               fac=-expon*(e1+evdwij)*rij_shift
14509               sigder=fac*sigder
14510               fac=rij*fac-2*expon*rrij*e_augm
14511 ! Calculate the radial part of the gradient
14512               gg(1)=xj*fac
14513               gg(2)=yj*fac
14514               gg(3)=zj*fac
14515 ! Calculate angular part of the gradient.
14516               call sc_grad_scale(sss)
14517             endif
14518           enddo      ! j
14519         enddo        ! iint
14520       enddo          ! i
14521       end subroutine egbv_short
14522 !-----------------------------------------------------------------------------
14523       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14524 !
14525 ! This subroutine calculates the average interaction energy and its gradient
14526 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14527 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14528 ! The potential depends both on the distance of peptide-group centers and on
14529 ! the orientation of the CA-CA virtual bonds.
14530 !
14531 !      implicit real*8 (a-h,o-z)
14532
14533       use comm_locel
14534 #ifdef MPI
14535       include 'mpif.h'
14536 #endif
14537 !      include 'DIMENSIONS'
14538 !      include 'COMMON.CONTROL'
14539 !      include 'COMMON.SETUP'
14540 !      include 'COMMON.IOUNITS'
14541 !      include 'COMMON.GEO'
14542 !      include 'COMMON.VAR'
14543 !      include 'COMMON.LOCAL'
14544 !      include 'COMMON.CHAIN'
14545 !      include 'COMMON.DERIV'
14546 !      include 'COMMON.INTERACT'
14547 !      include 'COMMON.CONTACTS'
14548 !      include 'COMMON.TORSION'
14549 !      include 'COMMON.VECTORS'
14550 !      include 'COMMON.FFIELD'
14551 !      include 'COMMON.TIME1'
14552       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14553       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14554       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14555 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14556       real(kind=8),dimension(4) :: muij
14557 !el      integer :: num_conti,j1,j2
14558 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14559 !el                   dz_normi,xmedi,ymedi,zmedi
14560 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14561 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14562 !el          num_conti,j1,j2
14563 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14564 #ifdef MOMENT
14565       real(kind=8) :: scal_el=1.0d0
14566 #else
14567       real(kind=8) :: scal_el=0.5d0
14568 #endif
14569 ! 12/13/98
14570 ! 13-go grudnia roku pamietnego...
14571       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14572                                              0.0d0,1.0d0,0.0d0,&
14573                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14574 !el local variables
14575       integer :: i,j,k
14576       real(kind=8) :: fac
14577       real(kind=8) :: dxj,dyj,dzj
14578       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14579
14580 !      allocate(num_cont_hb(nres)) !(maxres)
14581 !d      write(iout,*) 'In EELEC'
14582 !d      do i=1,nloctyp
14583 !d        write(iout,*) 'Type',i
14584 !d        write(iout,*) 'B1',B1(:,i)
14585 !d        write(iout,*) 'B2',B2(:,i)
14586 !d        write(iout,*) 'CC',CC(:,:,i)
14587 !d        write(iout,*) 'DD',DD(:,:,i)
14588 !d        write(iout,*) 'EE',EE(:,:,i)
14589 !d      enddo
14590 !d      call check_vecgrad
14591 !d      stop
14592       if (icheckgrad.eq.1) then
14593         do i=1,nres-1
14594           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14595           do k=1,3
14596             dc_norm(k,i)=dc(k,i)*fac
14597           enddo
14598 !          write (iout,*) 'i',i,' fac',fac
14599         enddo
14600       endif
14601       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14602           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14603           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14604 !        call vec_and_deriv
14605 #ifdef TIMING
14606         time01=MPI_Wtime()
14607 #endif
14608 !        print *, "before set matrices"
14609         call set_matrices
14610 !        print *,"after set martices"
14611 #ifdef TIMING
14612         time_mat=time_mat+MPI_Wtime()-time01
14613 #endif
14614       endif
14615 !d      do i=1,nres-1
14616 !d        write (iout,*) 'i=',i
14617 !d        do k=1,3
14618 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14619 !d        enddo
14620 !d        do k=1,3
14621 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14622 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14623 !d        enddo
14624 !d      enddo
14625       t_eelecij=0.0d0
14626       ees=0.0D0
14627       evdw1=0.0D0
14628       eel_loc=0.0d0
14629       eello_turn3=0.0d0
14630       eello_turn4=0.0d0
14631 !el      ind=0
14632       do i=1,nres
14633         num_cont_hb(i)=0
14634       enddo
14635 !d      print '(a)','Enter EELEC'
14636 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14637 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14638 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14639       do i=1,nres
14640         gel_loc_loc(i)=0.0d0
14641         gcorr_loc(i)=0.0d0
14642       enddo
14643 !
14644 !
14645 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14646 !
14647 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14648 !
14649       do i=iturn3_start,iturn3_end
14650         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14651         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14652         dxi=dc(1,i)
14653         dyi=dc(2,i)
14654         dzi=dc(3,i)
14655         dx_normi=dc_norm(1,i)
14656         dy_normi=dc_norm(2,i)
14657         dz_normi=dc_norm(3,i)
14658         xmedi=c(1,i)+0.5d0*dxi
14659         ymedi=c(2,i)+0.5d0*dyi
14660         zmedi=c(3,i)+0.5d0*dzi
14661         call to_box(xmedi,ymedi,zmedi)
14662         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14663         num_conti=0
14664         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14665         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14666         num_cont_hb(i)=num_conti
14667       enddo
14668       do i=iturn4_start,iturn4_end
14669         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14670           .or. itype(i+3,1).eq.ntyp1 &
14671           .or. itype(i+4,1).eq.ntyp1) cycle
14672         dxi=dc(1,i)
14673         dyi=dc(2,i)
14674         dzi=dc(3,i)
14675         dx_normi=dc_norm(1,i)
14676         dy_normi=dc_norm(2,i)
14677         dz_normi=dc_norm(3,i)
14678         xmedi=c(1,i)+0.5d0*dxi
14679         ymedi=c(2,i)+0.5d0*dyi
14680         zmedi=c(3,i)+0.5d0*dzi
14681
14682         call to_box(xmedi,ymedi,zmedi)
14683         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14684
14685         num_conti=num_cont_hb(i)
14686         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14687         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14688           call eturn4(i,eello_turn4)
14689         num_cont_hb(i)=num_conti
14690       enddo   ! i
14691 !
14692 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14693 !
14694       do i=iatel_s,iatel_e
14695         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14696         dxi=dc(1,i)
14697         dyi=dc(2,i)
14698         dzi=dc(3,i)
14699         dx_normi=dc_norm(1,i)
14700         dy_normi=dc_norm(2,i)
14701         dz_normi=dc_norm(3,i)
14702         xmedi=c(1,i)+0.5d0*dxi
14703         ymedi=c(2,i)+0.5d0*dyi
14704         zmedi=c(3,i)+0.5d0*dzi
14705         call to_box(xmedi,ymedi,zmedi)
14706         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14707 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14708         num_conti=num_cont_hb(i)
14709         do j=ielstart(i),ielend(i)
14710           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14711           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14712         enddo ! j
14713         num_cont_hb(i)=num_conti
14714       enddo   ! i
14715 !      write (iout,*) "Number of loop steps in EELEC:",ind
14716 !d      do i=1,nres
14717 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14718 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14719 !d      enddo
14720 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14721 !cc      eel_loc=eel_loc+eello_turn3
14722 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14723       return
14724       end subroutine eelec_scale
14725 !-----------------------------------------------------------------------------
14726       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14727 !      implicit real*8 (a-h,o-z)
14728
14729       use comm_locel
14730 !      include 'DIMENSIONS'
14731 #ifdef MPI
14732       include "mpif.h"
14733 #endif
14734 !      include 'COMMON.CONTROL'
14735 !      include 'COMMON.IOUNITS'
14736 !      include 'COMMON.GEO'
14737 !      include 'COMMON.VAR'
14738 !      include 'COMMON.LOCAL'
14739 !      include 'COMMON.CHAIN'
14740 !      include 'COMMON.DERIV'
14741 !      include 'COMMON.INTERACT'
14742 !      include 'COMMON.CONTACTS'
14743 !      include 'COMMON.TORSION'
14744 !      include 'COMMON.VECTORS'
14745 !      include 'COMMON.FFIELD'
14746 !      include 'COMMON.TIME1'
14747       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14748       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14749       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14750 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14751       real(kind=8),dimension(4) :: muij
14752       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14753                     dist_temp, dist_init,sss_grad
14754       integer xshift,yshift,zshift
14755
14756 !el      integer :: num_conti,j1,j2
14757 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14758 !el                   dz_normi,xmedi,ymedi,zmedi
14759 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14760 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14761 !el          num_conti,j1,j2
14762 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14763 #ifdef MOMENT
14764       real(kind=8) :: scal_el=1.0d0
14765 #else
14766       real(kind=8) :: scal_el=0.5d0
14767 #endif
14768 ! 12/13/98
14769 ! 13-go grudnia roku pamietnego...
14770       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14771                                              0.0d0,1.0d0,0.0d0,&
14772                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14773 !el local variables
14774       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14775       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14776       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14777       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14778       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14779       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14780       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14781                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14782                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14783                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14784                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14785                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
14786 !      integer :: maxconts
14787 !      maxconts = nres/4
14788 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14789 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14790 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14791 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14792 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14793 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14794 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14795 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14796 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14797 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14798 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14799 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14800 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14801
14802 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14803 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14804
14805 #ifdef MPI
14806           time00=MPI_Wtime()
14807 #endif
14808 !d      write (iout,*) "eelecij",i,j
14809 !el          ind=ind+1
14810           iteli=itel(i)
14811           itelj=itel(j)
14812           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14813           aaa=app(iteli,itelj)
14814           bbb=bpp(iteli,itelj)
14815           ael6i=ael6(iteli,itelj)
14816           ael3i=ael3(iteli,itelj)
14817           dxj=dc(1,j)
14818           dyj=dc(2,j)
14819           dzj=dc(3,j)
14820           dx_normj=dc_norm(1,j)
14821           dy_normj=dc_norm(2,j)
14822           dz_normj=dc_norm(3,j)
14823 !          xj=c(1,j)+0.5D0*dxj-xmedi
14824 !          yj=c(2,j)+0.5D0*dyj-ymedi
14825 !          zj=c(3,j)+0.5D0*dzj-zmedi
14826           xj=c(1,j)+0.5D0*dxj
14827           yj=c(2,j)+0.5D0*dyj
14828           zj=c(3,j)+0.5D0*dzj
14829           call to_box(xj,yj,zj)
14830           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14831           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
14832           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
14833           xj=boxshift(xj-xmedi,boxxsize)
14834           yj=boxshift(yj-ymedi,boxysize)
14835           zj=boxshift(zj-zmedi,boxzsize)
14836           rij=xj*xj+yj*yj+zj*zj
14837           rrmij=1.0D0/rij
14838           rij=dsqrt(rij)
14839           rmij=1.0D0/rij
14840 ! For extracting the short-range part of Evdwpp
14841           sss=sscale(rij/rpp(iteli,itelj))
14842             sss_ele_cut=sscale_ele(rij)
14843             sss_ele_grad=sscagrad_ele(rij)
14844             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14845 !             sss_ele_cut=1.0d0
14846 !             sss_ele_grad=0.0d0
14847             if (sss_ele_cut.le.0.0) go to 128
14848
14849           r3ij=rrmij*rmij
14850           r6ij=r3ij*r3ij
14851           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14852           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14853           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14854           fac=cosa-3.0D0*cosb*cosg
14855           ev1=aaa*r6ij*r6ij
14856 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14857           if (j.eq.i+2) ev1=scal_el*ev1
14858           ev2=bbb*r6ij
14859           fac3=ael6i*r6ij
14860           fac4=ael3i*r3ij
14861           evdwij=ev1+ev2
14862           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14863           el2=fac4*fac
14864           eesij=el1+el2
14865 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14866           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14867           ees=ees+eesij*sss_ele_cut
14868           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14869 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14870 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14871 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14872 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14873
14874           if (energy_dec) then
14875               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14876               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14877           endif
14878
14879 !
14880 ! Calculate contributions to the Cartesian gradient.
14881 !
14882 #ifdef SPLITELE
14883           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14884           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14885           fac1=fac
14886           erij(1)=xj*rmij
14887           erij(2)=yj*rmij
14888           erij(3)=zj*rmij
14889 !
14890 ! Radial derivatives. First process both termini of the fragment (i,j)
14891 !
14892           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14893           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14894           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14895 !          do k=1,3
14896 !            ghalf=0.5D0*ggg(k)
14897 !            gelc(k,i)=gelc(k,i)+ghalf
14898 !            gelc(k,j)=gelc(k,j)+ghalf
14899 !          enddo
14900 ! 9/28/08 AL Gradient compotents will be summed only at the end
14901           do k=1,3
14902             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14903             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14904           enddo
14905 !
14906 ! Loop over residues i+1 thru j-1.
14907 !
14908 !grad          do k=i+1,j-1
14909 !grad            do l=1,3
14910 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14911 !grad            enddo
14912 !grad          enddo
14913           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14914           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14915           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14916           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14917           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14918           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14919 !          do k=1,3
14920 !            ghalf=0.5D0*ggg(k)
14921 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14922 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14923 !          enddo
14924 ! 9/28/08 AL Gradient compotents will be summed only at the end
14925           do k=1,3
14926             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14927             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14928           enddo
14929 !
14930 ! Loop over residues i+1 thru j-1.
14931 !
14932 !grad          do k=i+1,j-1
14933 !grad            do l=1,3
14934 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14935 !grad            enddo
14936 !grad          enddo
14937 #else
14938           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14939           facel=(el1+eesij)*sss_ele_cut
14940           fac1=fac
14941           fac=-3*rrmij*(facvdw+facvdw+facel)
14942           erij(1)=xj*rmij
14943           erij(2)=yj*rmij
14944           erij(3)=zj*rmij
14945 !
14946 ! Radial derivatives. First process both termini of the fragment (i,j)
14947 !
14948           ggg(1)=fac*xj
14949           ggg(2)=fac*yj
14950           ggg(3)=fac*zj
14951 !          do k=1,3
14952 !            ghalf=0.5D0*ggg(k)
14953 !            gelc(k,i)=gelc(k,i)+ghalf
14954 !            gelc(k,j)=gelc(k,j)+ghalf
14955 !          enddo
14956 ! 9/28/08 AL Gradient compotents will be summed only at the end
14957           do k=1,3
14958             gelc_long(k,j)=gelc(k,j)+ggg(k)
14959             gelc_long(k,i)=gelc(k,i)-ggg(k)
14960           enddo
14961 !
14962 ! Loop over residues i+1 thru j-1.
14963 !
14964 !grad          do k=i+1,j-1
14965 !grad            do l=1,3
14966 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14967 !grad            enddo
14968 !grad          enddo
14969 ! 9/28/08 AL Gradient compotents will be summed only at the end
14970           ggg(1)=facvdw*xj
14971           ggg(2)=facvdw*yj
14972           ggg(3)=facvdw*zj
14973           do k=1,3
14974             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14975             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14976           enddo
14977 #endif
14978 !
14979 ! Angular part
14980 !
14981           ecosa=2.0D0*fac3*fac1+fac4
14982           fac4=-3.0D0*fac4
14983           fac3=-6.0D0*fac3
14984           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14985           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14986           do k=1,3
14987             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14988             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14989           enddo
14990 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14991 !d   &          (dcosg(k),k=1,3)
14992           do k=1,3
14993             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14994           enddo
14995 !          do k=1,3
14996 !            ghalf=0.5D0*ggg(k)
14997 !            gelc(k,i)=gelc(k,i)+ghalf
14998 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14999 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15000 !            gelc(k,j)=gelc(k,j)+ghalf
15001 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15002 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15003 !          enddo
15004 !grad          do k=i+1,j-1
15005 !grad            do l=1,3
15006 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15007 !grad            enddo
15008 !grad          enddo
15009           do k=1,3
15010             gelc(k,i)=gelc(k,i) &
15011                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15012                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15013                      *sss_ele_cut
15014             gelc(k,j)=gelc(k,j) &
15015                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15016                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15017                      *sss_ele_cut
15018             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15019             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15020           enddo
15021           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15022               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15023               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15024 !
15025 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15026 !   energy of a peptide unit is assumed in the form of a second-order
15027 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15028 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15029 !   are computed for EVERY pair of non-contiguous peptide groups.
15030 !
15031           if (j.lt.nres-1) then
15032             j1=j+1
15033             j2=j-1
15034           else
15035             j1=j-1
15036             j2=j-2
15037           endif
15038           kkk=0
15039           do k=1,2
15040             do l=1,2
15041               kkk=kkk+1
15042               muij(kkk)=mu(k,i)*mu(l,j)
15043             enddo
15044           enddo
15045 !d         write (iout,*) 'EELEC: i',i,' j',j
15046 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15047 !d          write(iout,*) 'muij',muij
15048           ury=scalar(uy(1,i),erij)
15049           urz=scalar(uz(1,i),erij)
15050           vry=scalar(uy(1,j),erij)
15051           vrz=scalar(uz(1,j),erij)
15052           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15053           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15054           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15055           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15056           fac=dsqrt(-ael6i)*r3ij
15057           a22=a22*fac
15058           a23=a23*fac
15059           a32=a32*fac
15060           a33=a33*fac
15061 !d          write (iout,'(4i5,4f10.5)')
15062 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15063 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15064 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15065 !d     &      uy(:,j),uz(:,j)
15066 !d          write (iout,'(4f10.5)')
15067 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15068 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15069 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15070 !d           write (iout,'(9f10.5/)')
15071 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15072 ! Derivatives of the elements of A in virtual-bond vectors
15073           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15074           do k=1,3
15075             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15076             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15077             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15078             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15079             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15080             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15081             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15082             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15083             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15084             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15085             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15086             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15087           enddo
15088 ! Compute radial contributions to the gradient
15089           facr=-3.0d0*rrmij
15090           a22der=a22*facr
15091           a23der=a23*facr
15092           a32der=a32*facr
15093           a33der=a33*facr
15094           agg(1,1)=a22der*xj
15095           agg(2,1)=a22der*yj
15096           agg(3,1)=a22der*zj
15097           agg(1,2)=a23der*xj
15098           agg(2,2)=a23der*yj
15099           agg(3,2)=a23der*zj
15100           agg(1,3)=a32der*xj
15101           agg(2,3)=a32der*yj
15102           agg(3,3)=a32der*zj
15103           agg(1,4)=a33der*xj
15104           agg(2,4)=a33der*yj
15105           agg(3,4)=a33der*zj
15106 ! Add the contributions coming from er
15107           fac3=-3.0d0*fac
15108           do k=1,3
15109             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15110             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15111             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15112             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15113           enddo
15114           do k=1,3
15115 ! Derivatives in DC(i)
15116 !grad            ghalf1=0.5d0*agg(k,1)
15117 !grad            ghalf2=0.5d0*agg(k,2)
15118 !grad            ghalf3=0.5d0*agg(k,3)
15119 !grad            ghalf4=0.5d0*agg(k,4)
15120             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15121             -3.0d0*uryg(k,2)*vry)!+ghalf1
15122             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15123             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15124             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15125             -3.0d0*urzg(k,2)*vry)!+ghalf3
15126             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15127             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15128 ! Derivatives in DC(i+1)
15129             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15130             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15131             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15132             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15133             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15134             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15135             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15136             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15137 ! Derivatives in DC(j)
15138             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15139             -3.0d0*vryg(k,2)*ury)!+ghalf1
15140             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15141             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15142             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15143             -3.0d0*vryg(k,2)*urz)!+ghalf3
15144             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15145             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15146 ! Derivatives in DC(j+1) or DC(nres-1)
15147             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15148             -3.0d0*vryg(k,3)*ury)
15149             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15150             -3.0d0*vrzg(k,3)*ury)
15151             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15152             -3.0d0*vryg(k,3)*urz)
15153             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15154             -3.0d0*vrzg(k,3)*urz)
15155 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15156 !grad              do l=1,4
15157 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15158 !grad              enddo
15159 !grad            endif
15160           enddo
15161           acipa(1,1)=a22
15162           acipa(1,2)=a23
15163           acipa(2,1)=a32
15164           acipa(2,2)=a33
15165           a22=-a22
15166           a23=-a23
15167           do l=1,2
15168             do k=1,3
15169               agg(k,l)=-agg(k,l)
15170               aggi(k,l)=-aggi(k,l)
15171               aggi1(k,l)=-aggi1(k,l)
15172               aggj(k,l)=-aggj(k,l)
15173               aggj1(k,l)=-aggj1(k,l)
15174             enddo
15175           enddo
15176           if (j.lt.nres-1) then
15177             a22=-a22
15178             a32=-a32
15179             do l=1,3,2
15180               do k=1,3
15181                 agg(k,l)=-agg(k,l)
15182                 aggi(k,l)=-aggi(k,l)
15183                 aggi1(k,l)=-aggi1(k,l)
15184                 aggj(k,l)=-aggj(k,l)
15185                 aggj1(k,l)=-aggj1(k,l)
15186               enddo
15187             enddo
15188           else
15189             a22=-a22
15190             a23=-a23
15191             a32=-a32
15192             a33=-a33
15193             do l=1,4
15194               do k=1,3
15195                 agg(k,l)=-agg(k,l)
15196                 aggi(k,l)=-aggi(k,l)
15197                 aggi1(k,l)=-aggi1(k,l)
15198                 aggj(k,l)=-aggj(k,l)
15199                 aggj1(k,l)=-aggj1(k,l)
15200               enddo
15201             enddo
15202           endif
15203           ENDIF ! WCORR
15204           IF (wel_loc.gt.0.0d0) THEN
15205 ! Contribution to the local-electrostatic energy coming from the i-j pair
15206           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15207            +a33*muij(4)
15208 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15209 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15210           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15211                   'eelloc',i,j,eel_loc_ij
15212 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15213
15214           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15215 ! Partial derivatives in virtual-bond dihedral angles gamma
15216           if (i.gt.1) &
15217           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15218                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15219                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15220                  *sss_ele_cut
15221           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15222                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15223                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15224                  *sss_ele_cut
15225            xtemp(1)=xj
15226            xtemp(2)=yj
15227            xtemp(3)=zj
15228
15229 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15230           do l=1,3
15231             ggg(l)=(agg(l,1)*muij(1)+ &
15232                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15233             *sss_ele_cut &
15234              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15235
15236             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15237             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15238 !grad            ghalf=0.5d0*ggg(l)
15239 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15240 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15241           enddo
15242 !grad          do k=i+1,j2
15243 !grad            do l=1,3
15244 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15245 !grad            enddo
15246 !grad          enddo
15247 ! Remaining derivatives of eello
15248           do l=1,3
15249             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15250                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15251             *sss_ele_cut
15252
15253             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15254                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15255             *sss_ele_cut
15256
15257             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15258                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15259             *sss_ele_cut
15260
15261             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15262                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15263             *sss_ele_cut
15264
15265           enddo
15266           ENDIF
15267 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15268 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15269           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15270              .and. num_conti.le.maxconts) then
15271 !            write (iout,*) i,j," entered corr"
15272 !
15273 ! Calculate the contact function. The ith column of the array JCONT will
15274 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15275 ! greater than I). The arrays FACONT and GACONT will contain the values of
15276 ! the contact function and its derivative.
15277 !           r0ij=1.02D0*rpp(iteli,itelj)
15278 !           r0ij=1.11D0*rpp(iteli,itelj)
15279             r0ij=2.20D0*rpp(iteli,itelj)
15280 !           r0ij=1.55D0*rpp(iteli,itelj)
15281             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15282 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15283             if (fcont.gt.0.0D0) then
15284               num_conti=num_conti+1
15285               if (num_conti.gt.maxconts) then
15286 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15287                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15288                                ' will skip next contacts for this conf.',num_conti
15289               else
15290                 jcont_hb(num_conti,i)=j
15291 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15292 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15293                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15294                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15295 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15296 !  terms.
15297                 d_cont(num_conti,i)=rij
15298 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15299 !     --- Electrostatic-interaction matrix ---
15300                 a_chuj(1,1,num_conti,i)=a22
15301                 a_chuj(1,2,num_conti,i)=a23
15302                 a_chuj(2,1,num_conti,i)=a32
15303                 a_chuj(2,2,num_conti,i)=a33
15304 !     --- Gradient of rij
15305                 do kkk=1,3
15306                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15307                 enddo
15308                 kkll=0
15309                 do k=1,2
15310                   do l=1,2
15311                     kkll=kkll+1
15312                     do m=1,3
15313                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15314                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15315                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15316                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15317                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15318                     enddo
15319                   enddo
15320                 enddo
15321                 ENDIF
15322                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15323 ! Calculate contact energies
15324                 cosa4=4.0D0*cosa
15325                 wij=cosa-3.0D0*cosb*cosg
15326                 cosbg1=cosb+cosg
15327                 cosbg2=cosb-cosg
15328 !               fac3=dsqrt(-ael6i)/r0ij**3
15329                 fac3=dsqrt(-ael6i)*r3ij
15330 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15331                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15332                 if (ees0tmp.gt.0) then
15333                   ees0pij=dsqrt(ees0tmp)
15334                 else
15335                   ees0pij=0
15336                 endif
15337 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15338                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15339                 if (ees0tmp.gt.0) then
15340                   ees0mij=dsqrt(ees0tmp)
15341                 else
15342                   ees0mij=0
15343                 endif
15344 !               ees0mij=0.0D0
15345                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15346                      *sss_ele_cut
15347
15348                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15349                      *sss_ele_cut
15350
15351 ! Diagnostics. Comment out or remove after debugging!
15352 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15353 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15354 !               ees0m(num_conti,i)=0.0D0
15355 ! End diagnostics.
15356 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15357 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15358 ! Angular derivatives of the contact function
15359                 ees0pij1=fac3/ees0pij
15360                 ees0mij1=fac3/ees0mij
15361                 fac3p=-3.0D0*fac3*rrmij
15362                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15363                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15364 !               ees0mij1=0.0D0
15365                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15366                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15367                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15368                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15369                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15370                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15371                 ecosap=ecosa1+ecosa2
15372                 ecosbp=ecosb1+ecosb2
15373                 ecosgp=ecosg1+ecosg2
15374                 ecosam=ecosa1-ecosa2
15375                 ecosbm=ecosb1-ecosb2
15376                 ecosgm=ecosg1-ecosg2
15377 ! Diagnostics
15378 !               ecosap=ecosa1
15379 !               ecosbp=ecosb1
15380 !               ecosgp=ecosg1
15381 !               ecosam=0.0D0
15382 !               ecosbm=0.0D0
15383 !               ecosgm=0.0D0
15384 ! End diagnostics
15385                 facont_hb(num_conti,i)=fcont
15386                 fprimcont=fprimcont/rij
15387 !d              facont_hb(num_conti,i)=1.0D0
15388 ! Following line is for diagnostics.
15389 !d              fprimcont=0.0D0
15390                 do k=1,3
15391                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15392                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15393                 enddo
15394                 do k=1,3
15395                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15396                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15397                 enddo
15398 !                gggp(1)=gggp(1)+ees0pijp*xj
15399 !                gggp(2)=gggp(2)+ees0pijp*yj
15400 !                gggp(3)=gggp(3)+ees0pijp*zj
15401 !                gggm(1)=gggm(1)+ees0mijp*xj
15402 !                gggm(2)=gggm(2)+ees0mijp*yj
15403 !                gggm(3)=gggm(3)+ees0mijp*zj
15404                 gggp(1)=gggp(1)+ees0pijp*xj &
15405                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15406                 gggp(2)=gggp(2)+ees0pijp*yj &
15407                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15408                 gggp(3)=gggp(3)+ees0pijp*zj &
15409                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15410
15411                 gggm(1)=gggm(1)+ees0mijp*xj &
15412                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15413
15414                 gggm(2)=gggm(2)+ees0mijp*yj &
15415                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15416
15417                 gggm(3)=gggm(3)+ees0mijp*zj &
15418                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15419
15420 ! Derivatives due to the contact function
15421                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15422                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15423                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15424                 do k=1,3
15425 !
15426 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15427 !          following the change of gradient-summation algorithm.
15428 !
15429 !grad                  ghalfp=0.5D0*gggp(k)
15430 !grad                  ghalfm=0.5D0*gggm(k)
15431 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15432 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15433 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15434 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15435 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15436 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15437 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15438 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15439 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15440 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15441 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15442 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15443 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15444 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15445                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15446                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15447                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15448                      *sss_ele_cut
15449
15450                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15451                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15452                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15453                      *sss_ele_cut
15454
15455                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15456                      *sss_ele_cut
15457
15458                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15459                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15460                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15461                      *sss_ele_cut
15462
15463                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15464                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15465                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15466                      *sss_ele_cut
15467
15468                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15469                      *sss_ele_cut
15470
15471                 enddo
15472               ENDIF ! wcorr
15473               endif  ! num_conti.le.maxconts
15474             endif  ! fcont.gt.0
15475           endif    ! j.gt.i+1
15476           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15477             do k=1,4
15478               do l=1,3
15479                 ghalf=0.5d0*agg(l,k)
15480                 aggi(l,k)=aggi(l,k)+ghalf
15481                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15482                 aggj(l,k)=aggj(l,k)+ghalf
15483               enddo
15484             enddo
15485             if (j.eq.nres-1 .and. i.lt.j-2) then
15486               do k=1,4
15487                 do l=1,3
15488                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15489                 enddo
15490               enddo
15491             endif
15492           endif
15493  128      continue
15494 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15495       return
15496       end subroutine eelecij_scale
15497 !-----------------------------------------------------------------------------
15498       subroutine evdwpp_short(evdw1)
15499 !
15500 ! Compute Evdwpp
15501 !
15502 !      implicit real*8 (a-h,o-z)
15503 !      include 'DIMENSIONS'
15504 !      include 'COMMON.CONTROL'
15505 !      include 'COMMON.IOUNITS'
15506 !      include 'COMMON.GEO'
15507 !      include 'COMMON.VAR'
15508 !      include 'COMMON.LOCAL'
15509 !      include 'COMMON.CHAIN'
15510 !      include 'COMMON.DERIV'
15511 !      include 'COMMON.INTERACT'
15512 !      include 'COMMON.CONTACTS'
15513 !      include 'COMMON.TORSION'
15514 !      include 'COMMON.VECTORS'
15515 !      include 'COMMON.FFIELD'
15516       real(kind=8),dimension(3) :: ggg
15517 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15518 #ifdef MOMENT
15519       real(kind=8) :: scal_el=1.0d0
15520 #else
15521       real(kind=8) :: scal_el=0.5d0
15522 #endif
15523 !el local variables
15524       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15525       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15526       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15527                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15528                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15529       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15530                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
15531                    sslipj,ssgradlipj,faclipij2
15532       integer xshift,yshift,zshift
15533
15534
15535       evdw1=0.0D0
15536 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15537 !     & " iatel_e_vdw",iatel_e_vdw
15538       call flush(iout)
15539       do i=iatel_s_vdw,iatel_e_vdw
15540         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15541         dxi=dc(1,i)
15542         dyi=dc(2,i)
15543         dzi=dc(3,i)
15544         dx_normi=dc_norm(1,i)
15545         dy_normi=dc_norm(2,i)
15546         dz_normi=dc_norm(3,i)
15547         xmedi=c(1,i)+0.5d0*dxi
15548         ymedi=c(2,i)+0.5d0*dyi
15549         zmedi=c(3,i)+0.5d0*dzi
15550         call to_box(xmedi,ymedi,zmedi)
15551         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15552         num_conti=0
15553 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15554 !     &   ' ielend',ielend_vdw(i)
15555         call flush(iout)
15556         do j=ielstart_vdw(i),ielend_vdw(i)
15557           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15558 !el          ind=ind+1
15559           iteli=itel(i)
15560           itelj=itel(j)
15561           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15562           aaa=app(iteli,itelj)
15563           bbb=bpp(iteli,itelj)
15564           dxj=dc(1,j)
15565           dyj=dc(2,j)
15566           dzj=dc(3,j)
15567           dx_normj=dc_norm(1,j)
15568           dy_normj=dc_norm(2,j)
15569           dz_normj=dc_norm(3,j)
15570 !          xj=c(1,j)+0.5D0*dxj-xmedi
15571 !          yj=c(2,j)+0.5D0*dyj-ymedi
15572 !          zj=c(3,j)+0.5D0*dzj-zmedi
15573           xj=c(1,j)+0.5D0*dxj
15574           yj=c(2,j)+0.5D0*dyj
15575           zj=c(3,j)+0.5D0*dzj
15576           call to_box(xj,yj,zj)
15577           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15578           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15579           xj=boxshift(xj-xmedi,boxxsize)
15580           yj=boxshift(yj-ymedi,boxysize)
15581           zj=boxshift(zj-zmedi,boxzsize)
15582           rij=xj*xj+yj*yj+zj*zj
15583           rrmij=1.0D0/rij
15584           rij=dsqrt(rij)
15585           sss=sscale(rij/rpp(iteli,itelj))
15586             sss_ele_cut=sscale_ele(rij)
15587             sss_ele_grad=sscagrad_ele(rij)
15588             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15589             if (sss_ele_cut.le.0.0) cycle
15590           if (sss.gt.0.0d0) then
15591             rmij=1.0D0/rij
15592             r3ij=rrmij*rmij
15593             r6ij=r3ij*r3ij
15594             ev1=aaa*r6ij*r6ij
15595 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15596             if (j.eq.i+2) ev1=scal_el*ev1
15597             ev2=bbb*r6ij
15598             evdwij=ev1+ev2
15599             if (energy_dec) then
15600               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15601             endif
15602             evdw1=evdw1+evdwij*sss*sss_ele_cut
15603 !
15604 ! Calculate contributions to the Cartesian gradient.
15605 !
15606             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15607 !            ggg(1)=facvdw*xj
15608 !            ggg(2)=facvdw*yj
15609 !            ggg(3)=facvdw*zj
15610           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15611           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15612           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15613           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15614           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15615           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15616
15617             do k=1,3
15618               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15619               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15620             enddo
15621           endif
15622         enddo ! j
15623       enddo   ! i
15624       return
15625       end subroutine evdwpp_short
15626 !-----------------------------------------------------------------------------
15627       subroutine escp_long(evdw2,evdw2_14)
15628 !
15629 ! This subroutine calculates the excluded-volume interaction energy between
15630 ! peptide-group centers and side chains and its gradient in virtual-bond and
15631 ! side-chain vectors.
15632 !
15633 !      implicit real*8 (a-h,o-z)
15634 !      include 'DIMENSIONS'
15635 !      include 'COMMON.GEO'
15636 !      include 'COMMON.VAR'
15637 !      include 'COMMON.LOCAL'
15638 !      include 'COMMON.CHAIN'
15639 !      include 'COMMON.DERIV'
15640 !      include 'COMMON.INTERACT'
15641 !      include 'COMMON.FFIELD'
15642 !      include 'COMMON.IOUNITS'
15643 !      include 'COMMON.CONTROL'
15644       real(kind=8),dimension(3) :: ggg
15645 !el local variables
15646       integer :: i,iint,j,k,iteli,itypj,subchap
15647       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15648       real(kind=8) :: evdw2,evdw2_14,evdwij
15649       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15650                     dist_temp, dist_init
15651
15652       evdw2=0.0D0
15653       evdw2_14=0.0d0
15654 !d    print '(a)','Enter ESCP'
15655 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15656       do i=iatscp_s,iatscp_e
15657         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15658         iteli=itel(i)
15659         xi=0.5D0*(c(1,i)+c(1,i+1))
15660         yi=0.5D0*(c(2,i)+c(2,i+1))
15661         zi=0.5D0*(c(3,i)+c(3,i+1))
15662         call to_box(xi,yi,zi)
15663         do iint=1,nscp_gr(i)
15664
15665         do j=iscpstart(i,iint),iscpend(i,iint)
15666           itypj=itype(j,1)
15667           if (itypj.eq.ntyp1) cycle
15668 ! Uncomment following three lines for SC-p interactions
15669 !         xj=c(1,nres+j)-xi
15670 !         yj=c(2,nres+j)-yi
15671 !         zj=c(3,nres+j)-zi
15672 ! Uncomment following three lines for Ca-p interactions
15673           xj=c(1,j)
15674           yj=c(2,j)
15675           zj=c(3,j)
15676           call to_box(xj,yj,zj)
15677           xj=boxshift(xj-xi,boxxsize)
15678           yj=boxshift(yj-yi,boxysize)
15679           zj=boxshift(zj-zi,boxzsize)
15680           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15681
15682           rij=dsqrt(1.0d0/rrij)
15683             sss_ele_cut=sscale_ele(rij)
15684             sss_ele_grad=sscagrad_ele(rij)
15685 !            print *,sss_ele_cut,sss_ele_grad,&
15686 !            (rij),r_cut_ele,rlamb_ele
15687             if (sss_ele_cut.le.0.0) cycle
15688           sss=sscale((rij/rscp(itypj,iteli)))
15689           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15690           if (sss.lt.1.0d0) then
15691
15692             fac=rrij**expon2
15693             e1=fac*fac*aad(itypj,iteli)
15694             e2=fac*bad(itypj,iteli)
15695             if (iabs(j-i) .le. 2) then
15696               e1=scal14*e1
15697               e2=scal14*e2
15698               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15699             endif
15700             evdwij=e1+e2
15701             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15702             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15703                 'evdw2',i,j,sss,evdwij
15704 !
15705 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15706 !
15707             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15708             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15709             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15710             ggg(1)=xj*fac
15711             ggg(2)=yj*fac
15712             ggg(3)=zj*fac
15713 ! Uncomment following three lines for SC-p interactions
15714 !           do k=1,3
15715 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15716 !           enddo
15717 ! Uncomment following line for SC-p interactions
15718 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15719             do k=1,3
15720               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15721               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15722             enddo
15723           endif
15724         enddo
15725
15726         enddo ! iint
15727       enddo ! i
15728       do i=1,nct
15729         do j=1,3
15730           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15731           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15732           gradx_scp(j,i)=expon*gradx_scp(j,i)
15733         enddo
15734       enddo
15735 !******************************************************************************
15736 !
15737 !                              N O T E !!!
15738 !
15739 ! To save time the factor EXPON has been extracted from ALL components
15740 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15741 ! use!
15742 !
15743 !******************************************************************************
15744       return
15745       end subroutine escp_long
15746 !-----------------------------------------------------------------------------
15747       subroutine escp_short(evdw2,evdw2_14)
15748 !
15749 ! This subroutine calculates the excluded-volume interaction energy between
15750 ! peptide-group centers and side chains and its gradient in virtual-bond and
15751 ! side-chain vectors.
15752 !
15753 !      implicit real*8 (a-h,o-z)
15754 !      include 'DIMENSIONS'
15755 !      include 'COMMON.GEO'
15756 !      include 'COMMON.VAR'
15757 !      include 'COMMON.LOCAL'
15758 !      include 'COMMON.CHAIN'
15759 !      include 'COMMON.DERIV'
15760 !      include 'COMMON.INTERACT'
15761 !      include 'COMMON.FFIELD'
15762 !      include 'COMMON.IOUNITS'
15763 !      include 'COMMON.CONTROL'
15764       real(kind=8),dimension(3) :: ggg
15765 !el local variables
15766       integer :: i,iint,j,k,iteli,itypj,subchap
15767       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15768       real(kind=8) :: evdw2,evdw2_14,evdwij
15769       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15770                     dist_temp, dist_init
15771
15772       evdw2=0.0D0
15773       evdw2_14=0.0d0
15774 !d    print '(a)','Enter ESCP'
15775 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15776       do i=iatscp_s,iatscp_e
15777         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15778         iteli=itel(i)
15779         xi=0.5D0*(c(1,i)+c(1,i+1))
15780         yi=0.5D0*(c(2,i)+c(2,i+1))
15781         zi=0.5D0*(c(3,i)+c(3,i+1))
15782         call to_box(xi,yi,zi)
15783         if (zi.lt.0) zi=zi+boxzsize
15784
15785         do iint=1,nscp_gr(i)
15786
15787         do j=iscpstart(i,iint),iscpend(i,iint)
15788           itypj=itype(j,1)
15789           if (itypj.eq.ntyp1) cycle
15790 ! Uncomment following three lines for SC-p interactions
15791 !         xj=c(1,nres+j)-xi
15792 !         yj=c(2,nres+j)-yi
15793 !         zj=c(3,nres+j)-zi
15794 ! Uncomment following three lines for Ca-p interactions
15795 !          xj=c(1,j)-xi
15796 !          yj=c(2,j)-yi
15797 !          zj=c(3,j)-zi
15798           xj=c(1,j)
15799           yj=c(2,j)
15800           zj=c(3,j)
15801           call to_box(xj,yj,zj)
15802           xj=boxshift(xj-xi,boxxsize)
15803           yj=boxshift(yj-yi,boxysize)
15804           zj=boxshift(zj-zi,boxzsize)
15805           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15806           rij=dsqrt(1.0d0/rrij)
15807             sss_ele_cut=sscale_ele(rij)
15808             sss_ele_grad=sscagrad_ele(rij)
15809 !            print *,sss_ele_cut,sss_ele_grad,&
15810 !            (rij),r_cut_ele,rlamb_ele
15811             if (sss_ele_cut.le.0.0) cycle
15812           sss=sscale(rij/rscp(itypj,iteli))
15813           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15814           if (sss.gt.0.0d0) then
15815
15816             fac=rrij**expon2
15817             e1=fac*fac*aad(itypj,iteli)
15818             e2=fac*bad(itypj,iteli)
15819             if (iabs(j-i) .le. 2) then
15820               e1=scal14*e1
15821               e2=scal14*e2
15822               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15823             endif
15824             evdwij=e1+e2
15825             evdw2=evdw2+evdwij*sss*sss_ele_cut
15826             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15827                 'evdw2',i,j,sss,evdwij
15828 !
15829 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15830 !
15831             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15832             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15833             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15834
15835             ggg(1)=xj*fac
15836             ggg(2)=yj*fac
15837             ggg(3)=zj*fac
15838 ! Uncomment following three lines for SC-p interactions
15839 !           do k=1,3
15840 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15841 !           enddo
15842 ! Uncomment following line for SC-p interactions
15843 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15844             do k=1,3
15845               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15846               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15847             enddo
15848           endif
15849         enddo
15850
15851         enddo ! iint
15852       enddo ! i
15853       do i=1,nct
15854         do j=1,3
15855           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15856           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15857           gradx_scp(j,i)=expon*gradx_scp(j,i)
15858         enddo
15859       enddo
15860 !******************************************************************************
15861 !
15862 !                              N O T E !!!
15863 !
15864 ! To save time the factor EXPON has been extracted from ALL components
15865 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15866 ! use!
15867 !
15868 !******************************************************************************
15869       return
15870       end subroutine escp_short
15871 !-----------------------------------------------------------------------------
15872 ! energy_p_new-sep_barrier.F
15873 !-----------------------------------------------------------------------------
15874       subroutine sc_grad_scale(scalfac)
15875 !      implicit real*8 (a-h,o-z)
15876       use calc_data
15877 !      include 'DIMENSIONS'
15878 !      include 'COMMON.CHAIN'
15879 !      include 'COMMON.DERIV'
15880 !      include 'COMMON.CALC'
15881 !      include 'COMMON.IOUNITS'
15882       real(kind=8),dimension(3) :: dcosom1,dcosom2
15883       real(kind=8) :: scalfac
15884 !el local variables
15885 !      integer :: i,j,k,l
15886
15887       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15888       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15889       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15890            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15891 ! diagnostics only
15892 !      eom1=0.0d0
15893 !      eom2=0.0d0
15894 !      eom12=evdwij*eps1_om12
15895 ! end diagnostics
15896 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15897 !     &  " sigder",sigder
15898 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15899 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15900       do k=1,3
15901         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15902         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15903       enddo
15904       do k=1,3
15905         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15906          *sss_ele_cut
15907       enddo
15908 !      write (iout,*) "gg",(gg(k),k=1,3)
15909       do k=1,3
15910         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15911                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15912                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15913                  *sss_ele_cut
15914         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15915                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15916                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15917          *sss_ele_cut
15918 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15919 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15920 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15921 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15922       enddo
15923 !
15924 ! Calculate the components of the gradient in DC and X
15925 !
15926       do l=1,3
15927         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15928         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15929       enddo
15930       return
15931       end subroutine sc_grad_scale
15932 !-----------------------------------------------------------------------------
15933 ! energy_split-sep.F
15934 !-----------------------------------------------------------------------------
15935       subroutine etotal_long(energia)
15936 !
15937 ! Compute the long-range slow-varying contributions to the energy
15938 !
15939 !      implicit real*8 (a-h,o-z)
15940 !      include 'DIMENSIONS'
15941       use MD_data, only: totT,usampl,eq_time
15942 #ifndef ISNAN
15943       external proc_proc
15944 #ifdef WINPGI
15945 !MS$ATTRIBUTES C ::  proc_proc
15946 #endif
15947 #endif
15948 #ifdef MPI
15949       include "mpif.h"
15950       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15951 #endif
15952 !      include 'COMMON.SETUP'
15953 !      include 'COMMON.IOUNITS'
15954 !      include 'COMMON.FFIELD'
15955 !      include 'COMMON.DERIV'
15956 !      include 'COMMON.INTERACT'
15957 !      include 'COMMON.SBRIDGE'
15958 !      include 'COMMON.CHAIN'
15959 !      include 'COMMON.VAR'
15960 !      include 'COMMON.LOCAL'
15961 !      include 'COMMON.MD'
15962       real(kind=8),dimension(0:n_ene) :: energia
15963 !el local variables
15964       integer :: i,n_corr,n_corr1,ierror,ierr
15965       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15966                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15967                   ecorr,ecorr5,ecorr6,eturn6,time00
15968 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15969 !elwrite(iout,*)"in etotal long"
15970
15971       if (modecalc.eq.12.or.modecalc.eq.14) then
15972 #ifdef MPI
15973 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15974 #else
15975         call int_from_cart1(.false.)
15976 #endif
15977       endif
15978 !elwrite(iout,*)"in etotal long"
15979
15980 #ifdef MPI
15981 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15982 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15983       call flush(iout)
15984       if (nfgtasks.gt.1) then
15985         time00=MPI_Wtime()
15986 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15987         if (fg_rank.eq.0) then
15988           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15989 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15990 !          call flush(iout)
15991 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15992 ! FG slaves as WEIGHTS array.
15993           weights_(1)=wsc
15994           weights_(2)=wscp
15995           weights_(3)=welec
15996           weights_(4)=wcorr
15997           weights_(5)=wcorr5
15998           weights_(6)=wcorr6
15999           weights_(7)=wel_loc
16000           weights_(8)=wturn3
16001           weights_(9)=wturn4
16002           weights_(10)=wturn6
16003           weights_(11)=wang
16004           weights_(12)=wscloc
16005           weights_(13)=wtor
16006           weights_(14)=wtor_d
16007           weights_(15)=wstrain
16008           weights_(16)=wvdwpp
16009           weights_(17)=wbond
16010           weights_(18)=scal14
16011           weights_(21)=wsccor
16012 ! FG Master broadcasts the WEIGHTS_ array
16013           call MPI_Bcast(weights_(1),n_ene,&
16014               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16015         else
16016 ! FG slaves receive the WEIGHTS array
16017           call MPI_Bcast(weights(1),n_ene,&
16018               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16019           wsc=weights(1)
16020           wscp=weights(2)
16021           welec=weights(3)
16022           wcorr=weights(4)
16023           wcorr5=weights(5)
16024           wcorr6=weights(6)
16025           wel_loc=weights(7)
16026           wturn3=weights(8)
16027           wturn4=weights(9)
16028           wturn6=weights(10)
16029           wang=weights(11)
16030           wscloc=weights(12)
16031           wtor=weights(13)
16032           wtor_d=weights(14)
16033           wstrain=weights(15)
16034           wvdwpp=weights(16)
16035           wbond=weights(17)
16036           scal14=weights(18)
16037           wsccor=weights(21)
16038         endif
16039         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16040           king,FG_COMM,IERR)
16041          time_Bcast=time_Bcast+MPI_Wtime()-time00
16042          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16043 !        call chainbuild_cart
16044 !        call int_from_cart1(.false.)
16045       endif
16046 !      write (iout,*) 'Processor',myrank,
16047 !     &  ' calling etotal_short ipot=',ipot
16048 !      call flush(iout)
16049 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16050 #endif
16051 !d    print *,'nnt=',nnt,' nct=',nct
16052 !
16053 !elwrite(iout,*)"in etotal long"
16054 ! Compute the side-chain and electrostatic interaction energy
16055 !
16056       goto (101,102,103,104,105,106) ipot
16057 ! Lennard-Jones potential.
16058   101 call elj_long(evdw)
16059 !d    print '(a)','Exit ELJ'
16060       goto 107
16061 ! Lennard-Jones-Kihara potential (shifted).
16062   102 call eljk_long(evdw)
16063       goto 107
16064 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16065   103 call ebp_long(evdw)
16066       goto 107
16067 ! Gay-Berne potential (shifted LJ, angular dependence).
16068   104 call egb_long(evdw)
16069       goto 107
16070 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16071   105 call egbv_long(evdw)
16072       goto 107
16073 ! Soft-sphere potential
16074   106 call e_softsphere(evdw)
16075 !
16076 ! Calculate electrostatic (H-bonding) energy of the main chain.
16077 !
16078   107 continue
16079       call vec_and_deriv
16080       if (ipot.lt.6) then
16081 #ifdef SPLITELE
16082          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16083              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16084              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16085              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16086 #else
16087          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16088              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16089              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16090              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16091 #endif
16092            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16093          else
16094             ees=0
16095             evdw1=0
16096             eel_loc=0
16097             eello_turn3=0
16098             eello_turn4=0
16099          endif
16100       else
16101 !        write (iout,*) "Soft-spheer ELEC potential"
16102         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16103          eello_turn4)
16104       endif
16105 !
16106 ! Calculate excluded-volume interaction energy between peptide groups
16107 ! and side chains.
16108 !
16109       if (ipot.lt.6) then
16110        if(wscp.gt.0d0) then
16111         call escp_long(evdw2,evdw2_14)
16112        else
16113         evdw2=0
16114         evdw2_14=0
16115        endif
16116       else
16117         call escp_soft_sphere(evdw2,evdw2_14)
16118       endif
16119 !
16120 ! 12/1/95 Multi-body terms
16121 !
16122       n_corr=0
16123       n_corr1=0
16124       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16125           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16126          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16127 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16128 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16129       else
16130          ecorr=0.0d0
16131          ecorr5=0.0d0
16132          ecorr6=0.0d0
16133          eturn6=0.0d0
16134       endif
16135       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16136          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16137       endif
16138 !
16139 ! If performing constraint dynamics, call the constraint energy
16140 !  after the equilibration time
16141       if(usampl.and.totT.gt.eq_time) then
16142          call EconstrQ
16143          call Econstr_back
16144       else
16145          Uconst=0.0d0
16146          Uconst_back=0.0d0
16147       endif
16148 !
16149 ! Sum the energies
16150 !
16151       do i=1,n_ene
16152         energia(i)=0.0d0
16153       enddo
16154       energia(1)=evdw
16155 #ifdef SCP14
16156       energia(2)=evdw2-evdw2_14
16157       energia(18)=evdw2_14
16158 #else
16159       energia(2)=evdw2
16160       energia(18)=0.0d0
16161 #endif
16162 #ifdef SPLITELE
16163       energia(3)=ees
16164       energia(16)=evdw1
16165 #else
16166       energia(3)=ees+evdw1
16167       energia(16)=0.0d0
16168 #endif
16169       energia(4)=ecorr
16170       energia(5)=ecorr5
16171       energia(6)=ecorr6
16172       energia(7)=eel_loc
16173       energia(8)=eello_turn3
16174       energia(9)=eello_turn4
16175       energia(10)=eturn6
16176       energia(20)=Uconst+Uconst_back
16177       call sum_energy(energia,.true.)
16178 !      write (iout,*) "Exit ETOTAL_LONG"
16179       call flush(iout)
16180       return
16181       end subroutine etotal_long
16182 !-----------------------------------------------------------------------------
16183       subroutine etotal_short(energia)
16184 !
16185 ! Compute the short-range fast-varying contributions to the energy
16186 !
16187 !      implicit real*8 (a-h,o-z)
16188 !      include 'DIMENSIONS'
16189 #ifndef ISNAN
16190       external proc_proc
16191 #ifdef WINPGI
16192 !MS$ATTRIBUTES C ::  proc_proc
16193 #endif
16194 #endif
16195 #ifdef MPI
16196       include "mpif.h"
16197       integer :: ierror,ierr
16198       real(kind=8),dimension(n_ene) :: weights_
16199       real(kind=8) :: time00
16200 #endif
16201 !      include 'COMMON.SETUP'
16202 !      include 'COMMON.IOUNITS'
16203 !      include 'COMMON.FFIELD'
16204 !      include 'COMMON.DERIV'
16205 !      include 'COMMON.INTERACT'
16206 !      include 'COMMON.SBRIDGE'
16207 !      include 'COMMON.CHAIN'
16208 !      include 'COMMON.VAR'
16209 !      include 'COMMON.LOCAL'
16210       real(kind=8),dimension(0:n_ene) :: energia
16211 !el local variables
16212       integer :: i,nres6
16213       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16214       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16215       nres6=6*nres
16216
16217 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16218 !      call flush(iout)
16219       if (modecalc.eq.12.or.modecalc.eq.14) then
16220 #ifdef MPI
16221         if (fg_rank.eq.0) call int_from_cart1(.false.)
16222 #else
16223         call int_from_cart1(.false.)
16224 #endif
16225       endif
16226 #ifdef MPI
16227 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16228 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16229 !      call flush(iout)
16230       if (nfgtasks.gt.1) then
16231         time00=MPI_Wtime()
16232 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16233         if (fg_rank.eq.0) then
16234           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16235 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16236 !          call flush(iout)
16237 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16238 ! FG slaves as WEIGHTS array.
16239           weights_(1)=wsc
16240           weights_(2)=wscp
16241           weights_(3)=welec
16242           weights_(4)=wcorr
16243           weights_(5)=wcorr5
16244           weights_(6)=wcorr6
16245           weights_(7)=wel_loc
16246           weights_(8)=wturn3
16247           weights_(9)=wturn4
16248           weights_(10)=wturn6
16249           weights_(11)=wang
16250           weights_(12)=wscloc
16251           weights_(13)=wtor
16252           weights_(14)=wtor_d
16253           weights_(15)=wstrain
16254           weights_(16)=wvdwpp
16255           weights_(17)=wbond
16256           weights_(18)=scal14
16257           weights_(21)=wsccor
16258 ! FG Master broadcasts the WEIGHTS_ array
16259           call MPI_Bcast(weights_(1),n_ene,&
16260               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16261         else
16262 ! FG slaves receive the WEIGHTS array
16263           call MPI_Bcast(weights(1),n_ene,&
16264               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16265           wsc=weights(1)
16266           wscp=weights(2)
16267           welec=weights(3)
16268           wcorr=weights(4)
16269           wcorr5=weights(5)
16270           wcorr6=weights(6)
16271           wel_loc=weights(7)
16272           wturn3=weights(8)
16273           wturn4=weights(9)
16274           wturn6=weights(10)
16275           wang=weights(11)
16276           wscloc=weights(12)
16277           wtor=weights(13)
16278           wtor_d=weights(14)
16279           wstrain=weights(15)
16280           wvdwpp=weights(16)
16281           wbond=weights(17)
16282           scal14=weights(18)
16283           wsccor=weights(21)
16284         endif
16285 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16286         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16287           king,FG_COMM,IERR)
16288 !        write (iout,*) "Processor",myrank," BROADCAST c"
16289         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16290           king,FG_COMM,IERR)
16291 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16292         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16293           king,FG_COMM,IERR)
16294 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16295         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16296           king,FG_COMM,IERR)
16297 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16298         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16299           king,FG_COMM,IERR)
16300 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16301         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16302           king,FG_COMM,IERR)
16303 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16304         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16305           king,FG_COMM,IERR)
16306 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16307         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16308           king,FG_COMM,IERR)
16309 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16310         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16311           king,FG_COMM,IERR)
16312          time_Bcast=time_Bcast+MPI_Wtime()-time00
16313 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16314       endif
16315 !      write (iout,*) 'Processor',myrank,
16316 !     &  ' calling etotal_short ipot=',ipot
16317 !      call flush(iout)
16318 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16319 #endif
16320 !      call int_from_cart1(.false.)
16321 !
16322 ! Compute the side-chain and electrostatic interaction energy
16323 !
16324       goto (101,102,103,104,105,106) ipot
16325 ! Lennard-Jones potential.
16326   101 call elj_short(evdw)
16327 !d    print '(a)','Exit ELJ'
16328       goto 107
16329 ! Lennard-Jones-Kihara potential (shifted).
16330   102 call eljk_short(evdw)
16331       goto 107
16332 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16333   103 call ebp_short(evdw)
16334       goto 107
16335 ! Gay-Berne potential (shifted LJ, angular dependence).
16336   104 call egb_short(evdw)
16337       goto 107
16338 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16339   105 call egbv_short(evdw)
16340       goto 107
16341 ! Soft-sphere potential - already dealt with in the long-range part
16342   106 evdw=0.0d0
16343 !  106 call e_softsphere_short(evdw)
16344 !
16345 ! Calculate electrostatic (H-bonding) energy of the main chain.
16346 !
16347   107 continue
16348 !
16349 ! Calculate the short-range part of Evdwpp
16350 !
16351       call evdwpp_short(evdw1)
16352 !
16353 ! Calculate the short-range part of ESCp
16354 !
16355       if (ipot.lt.6) then
16356        call escp_short(evdw2,evdw2_14)
16357       endif
16358 !
16359 ! Calculate the bond-stretching energy
16360 !
16361       call ebond(estr)
16362 !
16363 ! Calculate the disulfide-bridge and other energy and the contributions
16364 ! from other distance constraints.
16365       call edis(ehpb)
16366 !
16367 ! Calculate the virtual-bond-angle energy.
16368 !
16369 ! Calculate the SC local energy.
16370 !
16371       call vec_and_deriv
16372       call esc(escloc)
16373 !
16374       if (wang.gt.0d0) then
16375        if (tor_mode.eq.0) then
16376            call ebend(ebe)
16377        else
16378 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16379 !C energy function
16380         call ebend_kcc(ebe)
16381        endif
16382       else
16383           ebe=0.0d0
16384       endif
16385       ethetacnstr=0.0d0
16386       if (with_theta_constr) call etheta_constr(ethetacnstr)
16387
16388 !       write(iout,*) "in etotal afer ebe",ipot
16389
16390 !      print *,"Processor",myrank," computed UB"
16391 !
16392 ! Calculate the SC local energy.
16393 !
16394       call esc(escloc)
16395 !elwrite(iout,*) "in etotal afer esc",ipot
16396 !      print *,"Processor",myrank," computed USC"
16397 !
16398 ! Calculate the virtual-bond torsional energy.
16399 !
16400 !d    print *,'nterm=',nterm
16401 !      if (wtor.gt.0) then
16402 !       call etor(etors,edihcnstr)
16403 !      else
16404 !       etors=0
16405 !       edihcnstr=0
16406 !      endif
16407       if (wtor.gt.0.0d0) then
16408          if (tor_mode.eq.0) then
16409            call etor(etors)
16410           else
16411 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16412 !C energy function
16413         call etor_kcc(etors)
16414          endif
16415       else
16416            etors=0.0d0
16417       endif
16418       edihcnstr=0.0d0
16419       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16420
16421 ! Calculate the virtual-bond torsional energy.
16422 !
16423 !
16424 ! 6/23/01 Calculate double-torsional energy
16425 !
16426       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16427       call etor_d(etors_d)
16428       endif
16429 !
16430 ! 21/5/07 Calculate local sicdechain correlation energy
16431 !
16432       if (wsccor.gt.0.0d0) then
16433        call eback_sc_corr(esccor)
16434       else
16435        esccor=0.0d0
16436       endif
16437 !
16438 ! Put energy components into an array
16439 !
16440       do i=1,n_ene
16441        energia(i)=0.0d0
16442       enddo
16443       energia(1)=evdw
16444 #ifdef SCP14
16445       energia(2)=evdw2-evdw2_14
16446       energia(18)=evdw2_14
16447 #else
16448       energia(2)=evdw2
16449       energia(18)=0.0d0
16450 #endif
16451 #ifdef SPLITELE
16452       energia(16)=evdw1
16453 #else
16454       energia(3)=evdw1
16455 #endif
16456       energia(11)=ebe
16457       energia(12)=escloc
16458       energia(13)=etors
16459       energia(14)=etors_d
16460       energia(15)=ehpb
16461       energia(17)=estr
16462       energia(19)=edihcnstr
16463       energia(21)=esccor
16464 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16465       call flush(iout)
16466       call sum_energy(energia,.true.)
16467 !      write (iout,*) "Exit ETOTAL_SHORT"
16468       call flush(iout)
16469       return
16470       end subroutine etotal_short
16471 !-----------------------------------------------------------------------------
16472 ! gnmr1.f
16473 !-----------------------------------------------------------------------------
16474       real(kind=8) function gnmr1(y,ymin,ymax)
16475 !      implicit none
16476       real(kind=8) :: y,ymin,ymax
16477       real(kind=8) :: wykl=4.0d0
16478       if (y.lt.ymin) then
16479         gnmr1=(ymin-y)**wykl/wykl
16480       else if (y.gt.ymax) then
16481        gnmr1=(y-ymax)**wykl/wykl
16482       else
16483        gnmr1=0.0d0
16484       endif
16485       return
16486       end function gnmr1
16487 !-----------------------------------------------------------------------------
16488       real(kind=8) function gnmr1prim(y,ymin,ymax)
16489 !      implicit none
16490       real(kind=8) :: y,ymin,ymax
16491       real(kind=8) :: wykl=4.0d0
16492       if (y.lt.ymin) then
16493        gnmr1prim=-(ymin-y)**(wykl-1)
16494       else if (y.gt.ymax) then
16495        gnmr1prim=(y-ymax)**(wykl-1)
16496       else
16497        gnmr1prim=0.0d0
16498       endif
16499       return
16500       end function gnmr1prim
16501 !----------------------------------------------------------------------------
16502       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16503       real(kind=8) y,ymin,ymax,sigma
16504       real(kind=8) wykl /4.0d0/
16505       if (y.lt.ymin) then
16506         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16507       else if (y.gt.ymax) then
16508        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16509       else
16510         rlornmr1=0.0d0
16511       endif
16512       return
16513       end function rlornmr1
16514 !------------------------------------------------------------------------------
16515       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16516       real(kind=8) y,ymin,ymax,sigma
16517       real(kind=8) wykl /4.0d0/
16518       if (y.lt.ymin) then
16519         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16520         ((ymin-y)**wykl+sigma**wykl)**2
16521       else if (y.gt.ymax) then
16522          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16523         ((y-ymax)**wykl+sigma**wykl)**2
16524       else
16525        rlornmr1prim=0.0d0
16526       endif
16527       return
16528       end function rlornmr1prim
16529
16530       real(kind=8) function harmonic(y,ymax)
16531 !      implicit none
16532       real(kind=8) :: y,ymax
16533       real(kind=8) :: wykl=2.0d0
16534       harmonic=(y-ymax)**wykl
16535       return
16536       end function harmonic
16537 !-----------------------------------------------------------------------------
16538       real(kind=8) function harmonicprim(y,ymax)
16539       real(kind=8) :: y,ymin,ymax
16540       real(kind=8) :: wykl=2.0d0
16541       harmonicprim=(y-ymax)*wykl
16542       return
16543       end function harmonicprim
16544 !-----------------------------------------------------------------------------
16545 ! gradient_p.F
16546 !-----------------------------------------------------------------------------
16547       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16548
16549       use io_base, only:intout,briefout
16550 !      implicit real*8 (a-h,o-z)
16551 !      include 'DIMENSIONS'
16552 !      include 'COMMON.CHAIN'
16553 !      include 'COMMON.DERIV'
16554 !      include 'COMMON.VAR'
16555 !      include 'COMMON.INTERACT'
16556 !      include 'COMMON.FFIELD'
16557 !      include 'COMMON.MD'
16558 !      include 'COMMON.IOUNITS'
16559       real(kind=8),external :: ufparm
16560       integer :: uiparm(1)
16561       real(kind=8) :: urparm(1)
16562       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16563       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16564       integer :: n,nf,ind,ind1,i,k,j
16565 !
16566 ! This subroutine calculates total internal coordinate gradient.
16567 ! Depending on the number of function evaluations, either whole energy
16568 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16569 ! internal coordinates are reevaluated or only the cartesian-in-internal
16570 ! coordinate derivatives are evaluated. The subroutine was designed to work
16571 ! with SUMSL.
16572 !
16573 !
16574       icg=mod(nf,2)+1
16575
16576 !d      print *,'grad',nf,icg
16577       if (nf-nfl+1) 20,30,40
16578    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16579 !    write (iout,*) 'grad 20'
16580       if (nf.eq.0) return
16581       goto 40
16582    30 call var_to_geom(n,x)
16583       call chainbuild
16584 !    write (iout,*) 'grad 30'
16585 !
16586 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16587 !
16588    40 call cartder
16589 !     write (iout,*) 'grad 40'
16590 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16591 !
16592 ! Convert the Cartesian gradient into internal-coordinate gradient.
16593 !
16594       ind=0
16595       ind1=0
16596       do i=1,nres-2
16597       gthetai=0.0D0
16598       gphii=0.0D0
16599       do j=i+1,nres-1
16600         ind=ind+1
16601 !         ind=indmat(i,j)
16602 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16603        do k=1,3
16604        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16605         enddo
16606         do k=1,3
16607         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16608          enddo
16609        enddo
16610       do j=i+1,nres-1
16611         ind1=ind1+1
16612 !         ind1=indmat(i,j)
16613 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16614         do k=1,3
16615           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16616           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16617           enddo
16618         enddo
16619       if (i.gt.1) g(i-1)=gphii
16620       if (n.gt.nphi) g(nphi+i)=gthetai
16621       enddo
16622       if (n.le.nphi+ntheta) goto 10
16623       do i=2,nres-1
16624       if (itype(i,1).ne.10) then
16625           galphai=0.0D0
16626         gomegai=0.0D0
16627         do k=1,3
16628           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16629           enddo
16630         do k=1,3
16631           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16632           enddo
16633           g(ialph(i,1))=galphai
16634         g(ialph(i,1)+nside)=gomegai
16635         endif
16636       enddo
16637 !
16638 ! Add the components corresponding to local energy terms.
16639 !
16640    10 continue
16641       do i=1,nvar
16642 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16643         g(i)=g(i)+gloc(i,icg)
16644       enddo
16645 ! Uncomment following three lines for diagnostics.
16646 !d    call intout
16647 !elwrite(iout,*) "in gradient after calling intout"
16648 !d    call briefout(0,0.0d0)
16649 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16650       return
16651       end subroutine gradient
16652 !-----------------------------------------------------------------------------
16653       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16654
16655       use comm_chu
16656 !      implicit real*8 (a-h,o-z)
16657 !      include 'DIMENSIONS'
16658 !      include 'COMMON.DERIV'
16659 !      include 'COMMON.IOUNITS'
16660 !      include 'COMMON.GEO'
16661       integer :: n,nf
16662 !el      integer :: jjj
16663 !el      common /chuju/ jjj
16664       real(kind=8) :: energia(0:n_ene)
16665       integer :: uiparm(1)
16666       real(kind=8) :: urparm(1)
16667       real(kind=8) :: f
16668       real(kind=8),external :: ufparm
16669       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16670 !     if (jjj.gt.0) then
16671 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16672 !     endif
16673       nfl=nf
16674       icg=mod(nf,2)+1
16675 !d      print *,'func',nf,nfl,icg
16676       call var_to_geom(n,x)
16677       call zerograd
16678       call chainbuild
16679 !d    write (iout,*) 'ETOTAL called from FUNC'
16680       call etotal(energia)
16681       call sum_gradient
16682       f=energia(0)
16683 !     if (jjj.gt.0) then
16684 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16685 !       write (iout,*) 'f=',etot
16686 !       jjj=0
16687 !     endif
16688       return
16689       end subroutine func
16690 !-----------------------------------------------------------------------------
16691       subroutine cartgrad
16692 !      implicit real*8 (a-h,o-z)
16693 !      include 'DIMENSIONS'
16694       use energy_data
16695       use MD_data, only: totT,usampl,eq_time
16696 #ifdef MPI
16697       include 'mpif.h'
16698 #endif
16699 !      include 'COMMON.CHAIN'
16700 !      include 'COMMON.DERIV'
16701 !      include 'COMMON.VAR'
16702 !      include 'COMMON.INTERACT'
16703 !      include 'COMMON.FFIELD'
16704 !      include 'COMMON.MD'
16705 !      include 'COMMON.IOUNITS'
16706 !      include 'COMMON.TIME1'
16707 !
16708       integer :: i,j
16709       real(kind=8) :: time00,time01
16710
16711 ! This subrouting calculates total Cartesian coordinate gradient.
16712 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16713 !
16714 !#define DEBUG
16715 #ifdef TIMINGtime01
16716       time00=MPI_Wtime()
16717 #endif
16718       icg=1
16719       call sum_gradient
16720 #ifdef TIMING
16721 #endif
16722 !#define DEBUG
16723 !el      write (iout,*) "After sum_gradient"
16724 #ifdef DEBUG
16725       write (iout,*) "After sum_gradient"
16726       do i=1,nres-1
16727         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16728         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16729       enddo
16730 #endif
16731 !#undef DEBUG
16732 ! If performing constraint dynamics, add the gradients of the constraint energy
16733       if(usampl.and.totT.gt.eq_time) then
16734          do i=1,nct
16735            do j=1,3
16736              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16737              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16738            enddo
16739          enddo
16740          do i=1,nres-3
16741            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16742          enddo
16743          do i=1,nres-2
16744            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16745          enddo
16746       endif
16747 !elwrite (iout,*) "After sum_gradient"
16748 #ifdef TIMING
16749       time01=MPI_Wtime()
16750 #endif
16751       call intcartderiv
16752 !elwrite (iout,*) "After sum_gradient"
16753 #ifdef TIMING
16754       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16755 #endif
16756 !     call checkintcartgrad
16757 !     write(iout,*) 'calling int_to_cart'
16758 !#define DEBUG
16759 #ifdef DEBUG
16760       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16761 #endif
16762       do i=0,nct
16763         do j=1,3
16764           gcart(j,i)=gradc(j,i,icg)
16765           gxcart(j,i)=gradx(j,i,icg)
16766 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16767         enddo
16768 #ifdef DEBUG
16769         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16770           (gxcart(j,i),j=1,3),gloc(i,icg)
16771 #endif
16772       enddo
16773 #ifdef TIMING
16774       time01=MPI_Wtime()
16775 #endif
16776 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16777       call int_to_cart
16778 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16779
16780 #ifdef TIMING
16781             time_inttocart=time_inttocart+MPI_Wtime()-time01
16782 #endif
16783 #ifdef DEBUG
16784             write (iout,*) "gcart and gxcart after int_to_cart"
16785             do i=0,nres-1
16786             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16787             (gxcart(j,i),j=1,3)
16788             enddo
16789 #endif
16790 !#undef DEBUG
16791 #ifdef CARGRAD
16792 #ifdef DEBUG
16793             write (iout,*) "CARGRAD"
16794 #endif
16795             do i=nres,0,-1
16796             do j=1,3
16797               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16798       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16799             enddo
16800       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16801       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16802             enddo
16803       ! Correction: dummy residues
16804             if (nnt.gt.1) then
16805               do j=1,3
16806       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16807             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16808             enddo
16809           endif
16810           if (nct.lt.nres) then
16811             do j=1,3
16812       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16813             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16814             enddo
16815           endif
16816 #endif
16817 #ifdef TIMING
16818           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16819 #endif
16820 !#undef DEBUG
16821           return
16822           end subroutine cartgrad
16823       !-----------------------------------------------------------------------------
16824           subroutine zerograd
16825       !      implicit real*8 (a-h,o-z)
16826       !      include 'DIMENSIONS'
16827       !      include 'COMMON.DERIV'
16828       !      include 'COMMON.CHAIN'
16829       !      include 'COMMON.VAR'
16830       !      include 'COMMON.MD'
16831       !      include 'COMMON.SCCOR'
16832       !
16833       !el local variables
16834           integer :: i,j,intertyp,k
16835       ! Initialize Cartesian-coordinate gradient
16836       !
16837       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16838       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16839
16840       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16841       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16842       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16843       !      allocate(gradcorr_long(3,nres))
16844       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16845       !      allocate(gcorr6_turn_long(3,nres))
16846       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16847
16848       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16849
16850       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16851       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16852
16853       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16854       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16855
16856       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16857       !      allocate(gscloc(3,nres)) !(3,maxres)
16858       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16859
16860
16861
16862       !      common /deriv_scloc/
16863       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16864       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16865       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16866       !      common /mpgrad/
16867       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16868
16869
16870
16871       !          gradc(j,i,icg)=0.0d0
16872       !          gradx(j,i,icg)=0.0d0
16873
16874       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16875       !elwrite(iout,*) "icg",icg
16876           do i=-1,nres
16877           do j=1,3
16878             gvdwx(j,i)=0.0D0
16879             gradx_scp(j,i)=0.0D0
16880             gvdwc(j,i)=0.0D0
16881             gvdwc_scp(j,i)=0.0D0
16882             gvdwc_scpp(j,i)=0.0d0
16883             gelc(j,i)=0.0D0
16884             gelc_long(j,i)=0.0D0
16885             gradb(j,i)=0.0d0
16886             gradbx(j,i)=0.0d0
16887             gvdwpp(j,i)=0.0d0
16888             gel_loc(j,i)=0.0d0
16889             gel_loc_long(j,i)=0.0d0
16890             ghpbc(j,i)=0.0D0
16891             ghpbx(j,i)=0.0D0
16892             gcorr3_turn(j,i)=0.0d0
16893             gcorr4_turn(j,i)=0.0d0
16894             gradcorr(j,i)=0.0d0
16895             gradcorr_long(j,i)=0.0d0
16896             gradcorr5_long(j,i)=0.0d0
16897             gradcorr6_long(j,i)=0.0d0
16898             gcorr6_turn_long(j,i)=0.0d0
16899             gradcorr5(j,i)=0.0d0
16900             gradcorr6(j,i)=0.0d0
16901             gcorr6_turn(j,i)=0.0d0
16902             gsccorc(j,i)=0.0d0
16903             gsccorx(j,i)=0.0d0
16904             gradc(j,i,icg)=0.0d0
16905             gradx(j,i,icg)=0.0d0
16906             gscloc(j,i)=0.0d0
16907             gsclocx(j,i)=0.0d0
16908             gliptran(j,i)=0.0d0
16909             gliptranx(j,i)=0.0d0
16910             gliptranc(j,i)=0.0d0
16911             gshieldx(j,i)=0.0d0
16912             gshieldc(j,i)=0.0d0
16913             gshieldc_loc(j,i)=0.0d0
16914             gshieldx_ec(j,i)=0.0d0
16915             gshieldc_ec(j,i)=0.0d0
16916             gshieldc_loc_ec(j,i)=0.0d0
16917             gshieldx_t3(j,i)=0.0d0
16918             gshieldc_t3(j,i)=0.0d0
16919             gshieldc_loc_t3(j,i)=0.0d0
16920             gshieldx_t4(j,i)=0.0d0
16921             gshieldc_t4(j,i)=0.0d0
16922             gshieldc_loc_t4(j,i)=0.0d0
16923             gshieldx_ll(j,i)=0.0d0
16924             gshieldc_ll(j,i)=0.0d0
16925             gshieldc_loc_ll(j,i)=0.0d0
16926             gg_tube(j,i)=0.0d0
16927             gg_tube_sc(j,i)=0.0d0
16928             gradafm(j,i)=0.0d0
16929             gradb_nucl(j,i)=0.0d0
16930             gradbx_nucl(j,i)=0.0d0
16931             gvdwpp_nucl(j,i)=0.0d0
16932             gvdwpp(j,i)=0.0d0
16933             gelpp(j,i)=0.0d0
16934             gvdwpsb(j,i)=0.0d0
16935             gvdwpsb1(j,i)=0.0d0
16936             gvdwsbc(j,i)=0.0d0
16937             gvdwsbx(j,i)=0.0d0
16938             gelsbc(j,i)=0.0d0
16939             gradcorr_nucl(j,i)=0.0d0
16940             gradcorr3_nucl(j,i)=0.0d0
16941             gradxorr_nucl(j,i)=0.0d0
16942             gradxorr3_nucl(j,i)=0.0d0
16943             gelsbx(j,i)=0.0d0
16944             gsbloc(j,i)=0.0d0
16945             gsblocx(j,i)=0.0d0
16946             gradpepcat(j,i)=0.0d0
16947             gradpepcatx(j,i)=0.0d0
16948             gradcatcat(j,i)=0.0d0
16949             gvdwx_scbase(j,i)=0.0d0
16950             gvdwc_scbase(j,i)=0.0d0
16951             gvdwx_pepbase(j,i)=0.0d0
16952             gvdwc_pepbase(j,i)=0.0d0
16953             gvdwx_scpho(j,i)=0.0d0
16954             gvdwc_scpho(j,i)=0.0d0
16955             gvdwc_peppho(j,i)=0.0d0
16956             gradnuclcatx(j,i)=0.0d0
16957             gradnuclcat(j,i)=0.0d0
16958           enddo
16959            enddo
16960           do i=0,nres
16961           do j=1,3
16962             do intertyp=1,3
16963              gloc_sc(intertyp,i,icg)=0.0d0
16964             enddo
16965           enddo
16966           enddo
16967           do i=1,nres
16968            do j=1,maxcontsshi
16969            shield_list(j,i)=0
16970           do k=1,3
16971       !C           print *,i,j,k
16972              grad_shield_side(k,j,i)=0.0d0
16973              grad_shield_loc(k,j,i)=0.0d0
16974            enddo
16975            enddo
16976            ishield_list(i)=0
16977           enddo
16978
16979       !
16980       ! Initialize the gradient of local energy terms.
16981       !
16982       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16983       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16984       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16985       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16986       !      allocate(gel_loc_turn3(nres))
16987       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16988       !      allocate(gsccor_loc(nres))      !(maxres)
16989
16990           do i=1,4*nres
16991           gloc(i,icg)=0.0D0
16992           enddo
16993           do i=1,nres
16994           gel_loc_loc(i)=0.0d0
16995           gcorr_loc(i)=0.0d0
16996           g_corr5_loc(i)=0.0d0
16997           g_corr6_loc(i)=0.0d0
16998           gel_loc_turn3(i)=0.0d0
16999           gel_loc_turn4(i)=0.0d0
17000           gel_loc_turn6(i)=0.0d0
17001           gsccor_loc(i)=0.0d0
17002           enddo
17003       ! initialize gcart and gxcart
17004       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17005           do i=0,nres
17006           do j=1,3
17007             gcart(j,i)=0.0d0
17008             gxcart(j,i)=0.0d0
17009           enddo
17010           enddo
17011           return
17012           end subroutine zerograd
17013       !-----------------------------------------------------------------------------
17014           real(kind=8) function fdum()
17015           fdum=0.0D0
17016           return
17017           end function fdum
17018       !-----------------------------------------------------------------------------
17019       ! intcartderiv.F
17020       !-----------------------------------------------------------------------------
17021           subroutine intcartderiv
17022       !      implicit real*8 (a-h,o-z)
17023       !      include 'DIMENSIONS'
17024 #ifdef MPI
17025           include 'mpif.h'
17026 #endif
17027       !      include 'COMMON.SETUP'
17028       !      include 'COMMON.CHAIN'
17029       !      include 'COMMON.VAR'
17030       !      include 'COMMON.GEO'
17031       !      include 'COMMON.INTERACT'
17032       !      include 'COMMON.DERIV'
17033       !      include 'COMMON.IOUNITS'
17034       !      include 'COMMON.LOCAL'
17035       !      include 'COMMON.SCCOR'
17036           real(kind=8) :: pi4,pi34
17037           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17038           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17039                   dcosomega,dsinomega !(3,3,maxres)
17040           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17041
17042           integer :: i,j,k
17043           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17044                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17045                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17046                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17047           integer :: nres2
17048           nres2=2*nres
17049
17050       !el from module energy-------------
17051       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17052       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17053       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17054
17055       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17056       !el      allocate(dsintau(3,3,3,0:nres2))
17057       !el      allocate(dtauangle(3,3,3,0:nres2))
17058       !el      allocate(domicron(3,2,2,0:nres2))
17059       !el      allocate(dcosomicron(3,2,2,0:nres2))
17060
17061
17062
17063 #if defined(MPI) && defined(PARINTDER)
17064           if (nfgtasks.gt.1 .and. me.eq.king) &
17065           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17066 #endif
17067           pi4 = 0.5d0*pipol
17068           pi34 = 3*pi4
17069
17070       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17071       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17072
17073       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17074           do i=1,nres
17075           do j=1,3
17076             dtheta(j,1,i)=0.0d0
17077             dtheta(j,2,i)=0.0d0
17078             dphi(j,1,i)=0.0d0
17079             dphi(j,2,i)=0.0d0
17080             dphi(j,3,i)=0.0d0
17081             dcosomicron(j,1,1,i)=0.0d0
17082             dcosomicron(j,1,2,i)=0.0d0
17083             dcosomicron(j,2,1,i)=0.0d0
17084             dcosomicron(j,2,2,i)=0.0d0
17085           enddo
17086           enddo
17087       ! Derivatives of theta's
17088 #if defined(MPI) && defined(PARINTDER)
17089       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17090           do i=max0(ithet_start-1,3),ithet_end
17091 #else
17092           do i=3,nres
17093 #endif
17094           cost=dcos(theta(i))
17095           sint=sqrt(1-cost*cost)
17096           do j=1,3
17097             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17098             vbld(i-1)
17099             if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17100             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17101             vbld(i)
17102             if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17103           enddo
17104           enddo
17105 #if defined(MPI) && defined(PARINTDER)
17106       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17107           do i=max0(ithet_start-1,3),ithet_end
17108 #else
17109           do i=3,nres
17110 #endif
17111           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17112           cost1=dcos(omicron(1,i))
17113           sint1=sqrt(1-cost1*cost1)
17114           cost2=dcos(omicron(2,i))
17115           sint2=sqrt(1-cost2*cost2)
17116            do j=1,3
17117       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17118             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17119             cost1*dc_norm(j,i-2))/ &
17120             vbld(i-1)
17121             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17122             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17123             +cost1*(dc_norm(j,i-1+nres)))/ &
17124             vbld(i-1+nres)
17125             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17126       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17127       !C Looks messy but better than if in loop
17128             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17129             +cost2*dc_norm(j,i-1))/ &
17130             vbld(i)
17131             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17132             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17133              +cost2*(-dc_norm(j,i-1+nres)))/ &
17134             vbld(i-1+nres)
17135       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17136             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17137           enddo
17138            endif
17139           enddo
17140       !elwrite(iout,*) "after vbld write"
17141       ! Derivatives of phi:
17142       ! If phi is 0 or 180 degrees, then the formulas
17143       ! have to be derived by power series expansion of the
17144       ! conventional formulas around 0 and 180.
17145 #ifdef PARINTDER
17146           do i=iphi1_start,iphi1_end
17147 #else
17148           do i=4,nres
17149 #endif
17150       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17151       ! the conventional case
17152           sint=dsin(theta(i))
17153           sint1=dsin(theta(i-1))
17154           sing=dsin(phi(i))
17155           cost=dcos(theta(i))
17156           cost1=dcos(theta(i-1))
17157           cosg=dcos(phi(i))
17158           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17159           fac0=1.0d0/(sint1*sint)
17160           fac1=cost*fac0
17161           fac2=cost1*fac0
17162           fac3=cosg*cost1/(sint1*sint1)
17163           fac4=cosg*cost/(sint*sint)
17164       !    Obtaining the gamma derivatives from sine derivative
17165            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17166              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17167              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17168            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17169            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17170            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17171            do j=1,3
17172             ctgt=cost/sint
17173             ctgt1=cost1/sint1
17174             cosg_inv=1.0d0/cosg
17175             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17176             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17177               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17178             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17179             dsinphi(j,2,i)= &
17180               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17181               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17182             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17183             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17184               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17185       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17186             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17187             endif
17188       ! Bug fixed 3/24/05 (AL)
17189            enddo
17190       !   Obtaining the gamma derivatives from cosine derivative
17191           else
17192              do j=1,3
17193              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17194              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17195              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17196              dc_norm(j,i-3))/vbld(i-2)
17197              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17198              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17199              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17200              dcostheta(j,1,i)
17201              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17202              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17203              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17204              dc_norm(j,i-1))/vbld(i)
17205              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17206 !#define DEBUG
17207 #ifdef DEBUG
17208              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17209 #endif
17210 !#undef DEBUG
17211              endif
17212            enddo
17213           endif
17214           enddo
17215       !alculate derivative of Tauangle
17216 #ifdef PARINTDER
17217           do i=itau_start,itau_end
17218 #else
17219           do i=3,nres
17220       !elwrite(iout,*) " vecpr",i,nres
17221 #endif
17222            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17223       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17224       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17225       !c dtauangle(j,intertyp,dervityp,residue number)
17226       !c INTERTYP=1 SC...Ca...Ca..Ca
17227       ! the conventional case
17228           sint=dsin(theta(i))
17229           sint1=dsin(omicron(2,i-1))
17230           sing=dsin(tauangle(1,i))
17231           cost=dcos(theta(i))
17232           cost1=dcos(omicron(2,i-1))
17233           cosg=dcos(tauangle(1,i))
17234       !elwrite(iout,*) " vecpr5",i,nres
17235           do j=1,3
17236       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17237       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17238           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17239       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17240           enddo
17241           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17242           fac0=1.0d0/(sint1*sint)
17243           fac1=cost*fac0
17244           fac2=cost1*fac0
17245           fac3=cosg*cost1/(sint1*sint1)
17246           fac4=cosg*cost/(sint*sint)
17247       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17248       !    Obtaining the gamma derivatives from sine derivative
17249            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17250              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17251              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17252            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17253            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17254            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17255           do j=1,3
17256             ctgt=cost/sint
17257             ctgt1=cost1/sint1
17258             cosg_inv=1.0d0/cosg
17259             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17260            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17261            *vbld_inv(i-2+nres)
17262             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17263             dsintau(j,1,2,i)= &
17264               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17265               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17266       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17267             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17268       ! Bug fixed 3/24/05 (AL)
17269             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17270               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17271       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17272             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17273            enddo
17274       !   Obtaining the gamma derivatives from cosine derivative
17275           else
17276              do j=1,3
17277              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17278              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17279              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17280              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17281              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17282              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17283              dcostheta(j,1,i)
17284              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17285              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17286              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17287              dc_norm(j,i-1))/vbld(i)
17288              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17289       !         write (iout,*) "else",i
17290            enddo
17291           endif
17292       !        do k=1,3
17293       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17294       !        enddo
17295           enddo
17296       !C Second case Ca...Ca...Ca...SC
17297 #ifdef PARINTDER
17298           do i=itau_start,itau_end
17299 #else
17300           do i=4,nres
17301 #endif
17302            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17303             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17304       ! the conventional case
17305           sint=dsin(omicron(1,i))
17306           sint1=dsin(theta(i-1))
17307           sing=dsin(tauangle(2,i))
17308           cost=dcos(omicron(1,i))
17309           cost1=dcos(theta(i-1))
17310           cosg=dcos(tauangle(2,i))
17311       !        do j=1,3
17312       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17313       !        enddo
17314           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17315           fac0=1.0d0/(sint1*sint)
17316           fac1=cost*fac0
17317           fac2=cost1*fac0
17318           fac3=cosg*cost1/(sint1*sint1)
17319           fac4=cosg*cost/(sint*sint)
17320       !    Obtaining the gamma derivatives from sine derivative
17321            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17322              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17323              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17324            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17325            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17326            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17327           do j=1,3
17328             ctgt=cost/sint
17329             ctgt1=cost1/sint1
17330             cosg_inv=1.0d0/cosg
17331             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17332               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17333       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17334       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17335             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17336             dsintau(j,2,2,i)= &
17337               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17338               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17339       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17340       !     & sing*ctgt*domicron(j,1,2,i),
17341       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17342             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17343       ! Bug fixed 3/24/05 (AL)
17344             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17345              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17346       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17347             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17348            enddo
17349       !   Obtaining the gamma derivatives from cosine derivative
17350           else
17351              do j=1,3
17352              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17353              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17354              dc_norm(j,i-3))/vbld(i-2)
17355              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17356              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17357              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17358              dcosomicron(j,1,1,i)
17359              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17360              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17361              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17362              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17363              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17364       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17365            enddo
17366           endif
17367           enddo
17368
17369       !CC third case SC...Ca...Ca...SC
17370 #ifdef PARINTDER
17371
17372           do i=itau_start,itau_end
17373 #else
17374           do i=3,nres
17375 #endif
17376       ! the conventional case
17377           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17378           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17379           sint=dsin(omicron(1,i))
17380           sint1=dsin(omicron(2,i-1))
17381           sing=dsin(tauangle(3,i))
17382           cost=dcos(omicron(1,i))
17383           cost1=dcos(omicron(2,i-1))
17384           cosg=dcos(tauangle(3,i))
17385           do j=1,3
17386           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17387       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17388           enddo
17389           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17390           fac0=1.0d0/(sint1*sint)
17391           fac1=cost*fac0
17392           fac2=cost1*fac0
17393           fac3=cosg*cost1/(sint1*sint1)
17394           fac4=cosg*cost/(sint*sint)
17395       !    Obtaining the gamma derivatives from sine derivative
17396            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17397              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17398              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17399            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17400            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17401            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17402           do j=1,3
17403             ctgt=cost/sint
17404             ctgt1=cost1/sint1
17405             cosg_inv=1.0d0/cosg
17406             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17407               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17408               *vbld_inv(i-2+nres)
17409             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17410             dsintau(j,3,2,i)= &
17411               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17412               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17413             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17414       ! Bug fixed 3/24/05 (AL)
17415             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17416               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17417               *vbld_inv(i-1+nres)
17418       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17419             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17420            enddo
17421       !   Obtaining the gamma derivatives from cosine derivative
17422           else
17423              do j=1,3
17424              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17425              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17426              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17427              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17428              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17429              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17430              dcosomicron(j,1,1,i)
17431              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17432              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17433              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17434              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17435              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17436       !          write(iout,*) "else",i
17437            enddo
17438           endif
17439           enddo
17440
17441 #ifdef CRYST_SC
17442       !   Derivatives of side-chain angles alpha and omega
17443 #if defined(MPI) && defined(PARINTDER)
17444           do i=ibond_start,ibond_end
17445 #else
17446           do i=2,nres-1
17447 #endif
17448             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17449              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17450              fac6=fac5/vbld(i)
17451              fac7=fac5*fac5
17452              fac8=fac5/vbld(i+1)
17453              fac9=fac5/vbld(i+nres)
17454              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17455              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17456              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17457              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17458              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17459              sina=sqrt(1-cosa*cosa)
17460              sino=dsin(omeg(i))
17461       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17462              do j=1,3
17463               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17464               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17465               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17466               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17467               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17468               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17469               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17470               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17471               vbld(i+nres))
17472               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17473             enddo
17474       ! obtaining the derivatives of omega from sines
17475             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17476                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17477                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17478                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17479                dsin(theta(i+1)))
17480                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17481                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17482                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17483                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17484                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17485                coso_inv=1.0d0/dcos(omeg(i))
17486                do j=1,3
17487                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17488                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17489                (sino*dc_norm(j,i-1))/vbld(i)
17490                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17491                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17492                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17493                -sino*dc_norm(j,i)/vbld(i+1)
17494                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17495                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17496                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17497                vbld(i+nres)
17498                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17499               enddo
17500              else
17501       !   obtaining the derivatives of omega from cosines
17502              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17503              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17504              fac12=fac10*sina
17505              fac13=fac12*fac12
17506              fac14=sina*sina
17507              do j=1,3
17508               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17509               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17510               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17511               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17512               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17513               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17514               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17515               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17516               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17517               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17518               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17519               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17520               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17521               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17522               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17523             enddo
17524             endif
17525            else
17526              do j=1,3
17527              do k=1,3
17528                dalpha(k,j,i)=0.0d0
17529                domega(k,j,i)=0.0d0
17530              enddo
17531              enddo
17532            endif
17533            enddo
17534 #endif
17535 #if defined(MPI) && defined(PARINTDER)
17536           if (nfgtasks.gt.1) then
17537 #ifdef DEBUG
17538       !d      write (iout,*) "Gather dtheta"
17539       !d      call flush(iout)
17540           write (iout,*) "dtheta before gather"
17541           do i=1,nres
17542           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17543           enddo
17544 #endif
17545           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17546           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17547           king,FG_COMM,IERROR)
17548 !#define DEBUG
17549 #ifdef DEBUG
17550       !d      write (iout,*) "Gather dphi"
17551       !d      call flush(iout)
17552           write (iout,*) "dphi before gather"
17553           do i=1,nres
17554           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17555           enddo
17556 #endif
17557 !#undef DEBUG
17558           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17559           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17560           king,FG_COMM,IERROR)
17561       !d      write (iout,*) "Gather dalpha"
17562       !d      call flush(iout)
17563 #ifdef CRYST_SC
17564           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17565           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17566           king,FG_COMM,IERROR)
17567       !d      write (iout,*) "Gather domega"
17568       !d      call flush(iout)
17569           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17570           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17571           king,FG_COMM,IERROR)
17572 #endif
17573           endif
17574 #endif
17575 !#define DEBUG
17576 #ifdef DEBUG
17577           write (iout,*) "dtheta after gather"
17578           do i=1,nres
17579           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17580           enddo
17581           write (iout,*) "dphi after gather"
17582           do i=1,nres
17583           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17584           enddo
17585           write (iout,*) "dalpha after gather"
17586           do i=1,nres
17587           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17588           enddo
17589           write (iout,*) "domega after gather"
17590           do i=1,nres
17591           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17592           enddo
17593 #endif
17594 !#undef DEBUG
17595           return
17596           end subroutine intcartderiv
17597       !-----------------------------------------------------------------------------
17598           subroutine checkintcartgrad
17599       !      implicit real*8 (a-h,o-z)
17600       !      include 'DIMENSIONS'
17601 #ifdef MPI
17602           include 'mpif.h'
17603 #endif
17604       !      include 'COMMON.CHAIN'
17605       !      include 'COMMON.VAR'
17606       !      include 'COMMON.GEO'
17607       !      include 'COMMON.INTERACT'
17608       !      include 'COMMON.DERIV'
17609       !      include 'COMMON.IOUNITS'
17610       !      include 'COMMON.SETUP'
17611           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17612           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17613           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17614           real(kind=8),dimension(3) :: dc_norm_s
17615           real(kind=8) :: aincr=1.0d-5
17616           integer :: i,j
17617           real(kind=8) :: dcji
17618           do i=1,nres
17619           phi_s(i)=phi(i)
17620           theta_s(i)=theta(i)
17621           alph_s(i)=alph(i)
17622           omeg_s(i)=omeg(i)
17623           enddo
17624       ! Check theta gradient
17625           write (iout,*) &
17626            "Analytical (upper) and numerical (lower) gradient of theta"
17627           write (iout,*)
17628           do i=3,nres
17629           do j=1,3
17630             dcji=dc(j,i-2)
17631             dc(j,i-2)=dcji+aincr
17632             call chainbuild_cart
17633             call int_from_cart1(.false.)
17634         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17635         dc(j,i-2)=dcji
17636         dcji=dc(j,i-1)
17637         dc(j,i-1)=dc(j,i-1)+aincr
17638         call chainbuild_cart
17639         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17640         dc(j,i-1)=dcji
17641       enddo
17642 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17643 !el          (dtheta(j,2,i),j=1,3)
17644 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17645 !el          (dthetanum(j,2,i),j=1,3)
17646 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17647 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17648 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17649 !el        write (iout,*)
17650       enddo
17651 ! Check gamma gradient
17652       write (iout,*) &
17653        "Analytical (upper) and numerical (lower) gradient of gamma"
17654       do i=4,nres
17655       do j=1,3
17656         dcji=dc(j,i-3)
17657         dc(j,i-3)=dcji+aincr
17658         call chainbuild_cart
17659         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17660             dc(j,i-3)=dcji
17661         dcji=dc(j,i-2)
17662         dc(j,i-2)=dcji+aincr
17663         call chainbuild_cart
17664         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17665         dc(j,i-2)=dcji
17666         dcji=dc(j,i-1)
17667         dc(j,i-1)=dc(j,i-1)+aincr
17668         call chainbuild_cart
17669         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17670         dc(j,i-1)=dcji
17671       enddo
17672 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17673 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17674 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17675 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17676 !el        write (iout,'(5x,3(3f10.5,5x))') &
17677 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17678 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17679 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17680 !el        write (iout,*)
17681       enddo
17682 ! Check alpha gradient
17683       write (iout,*) &
17684        "Analytical (upper) and numerical (lower) gradient of alpha"
17685       do i=2,nres-1
17686        if(itype(i,1).ne.10) then
17687              do j=1,3
17688               dcji=dc(j,i-1)
17689                dc(j,i-1)=dcji+aincr
17690             call chainbuild_cart
17691             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17692              /aincr
17693               dc(j,i-1)=dcji
17694             dcji=dc(j,i)
17695             dc(j,i)=dcji+aincr
17696             call chainbuild_cart
17697             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17698              /aincr
17699             dc(j,i)=dcji
17700             dcji=dc(j,i+nres)
17701             dc(j,i+nres)=dc(j,i+nres)+aincr
17702             call chainbuild_cart
17703             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17704              /aincr
17705            dc(j,i+nres)=dcji
17706           enddo
17707         endif
17708 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17709 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17710 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17711 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17712 !el        write (iout,'(5x,3(3f10.5,5x))') &
17713 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17714 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17715 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17716 !el        write (iout,*)
17717       enddo
17718 !     Check omega gradient
17719       write (iout,*) &
17720        "Analytical (upper) and numerical (lower) gradient of omega"
17721       do i=2,nres-1
17722        if(itype(i,1).ne.10) then
17723              do j=1,3
17724               dcji=dc(j,i-1)
17725                dc(j,i-1)=dcji+aincr
17726             call chainbuild_cart
17727             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17728              /aincr
17729               dc(j,i-1)=dcji
17730             dcji=dc(j,i)
17731             dc(j,i)=dcji+aincr
17732             call chainbuild_cart
17733             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17734              /aincr
17735             dc(j,i)=dcji
17736             dcji=dc(j,i+nres)
17737             dc(j,i+nres)=dc(j,i+nres)+aincr
17738             call chainbuild_cart
17739             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17740              /aincr
17741            dc(j,i+nres)=dcji
17742           enddo
17743         endif
17744 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17745 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17746 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17747 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17748 !el        write (iout,'(5x,3(3f10.5,5x))') &
17749 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17750 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17751 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17752 !el        write (iout,*)
17753       enddo
17754       return
17755       end subroutine checkintcartgrad
17756 !-----------------------------------------------------------------------------
17757 ! q_measure.F
17758 !-----------------------------------------------------------------------------
17759       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17760 !      implicit real*8 (a-h,o-z)
17761 !      include 'DIMENSIONS'
17762 !      include 'COMMON.IOUNITS'
17763 !      include 'COMMON.CHAIN'
17764 !      include 'COMMON.INTERACT'
17765 !      include 'COMMON.VAR'
17766       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17767       integer :: kkk,nsep=3
17768       real(kind=8) :: qm      !dist,
17769       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17770       logical :: lprn=.false.
17771       logical :: flag
17772 !      real(kind=8) :: sigm,x
17773
17774 !el      sigm(x)=0.25d0*x     ! local function
17775       qqmax=1.0d10
17776       do kkk=1,nperm
17777       qq = 0.0d0
17778       nl=0
17779        if(flag) then
17780       do il=seg1+nsep,seg2
17781         do jl=seg1,il-nsep
17782           nl=nl+1
17783           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17784                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17785                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17786           dij=dist(il,jl)
17787           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17788           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17789             nl=nl+1
17790             d0ijCM=dsqrt( &
17791                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17792                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17793                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17794             dijCM=dist(il+nres,jl+nres)
17795             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17796           endif
17797           qq = qq+qqij+qqijCM
17798         enddo
17799       enddo
17800       qq = qq/nl
17801       else
17802       do il=seg1,seg2
17803       if((seg3-il).lt.3) then
17804            secseg=il+3
17805       else
17806            secseg=seg3
17807       endif
17808         do jl=secseg,seg4
17809           nl=nl+1
17810           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17811                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17812                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17813           dij=dist(il,jl)
17814           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17815           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17816             nl=nl+1
17817             d0ijCM=dsqrt( &
17818                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17819                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17820                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17821             dijCM=dist(il+nres,jl+nres)
17822             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17823           endif
17824           qq = qq+qqij+qqijCM
17825         enddo
17826       enddo
17827       qq = qq/nl
17828       endif
17829       if (qqmax.le.qq) qqmax=qq
17830       enddo
17831       qwolynes=1.0d0-qqmax
17832       return
17833       end function qwolynes
17834 !-----------------------------------------------------------------------------
17835       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17836 !      implicit real*8 (a-h,o-z)
17837 !      include 'DIMENSIONS'
17838 !      include 'COMMON.IOUNITS'
17839 !      include 'COMMON.CHAIN'
17840 !      include 'COMMON.INTERACT'
17841 !      include 'COMMON.VAR'
17842 !      include 'COMMON.MD'
17843       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17844       integer :: nsep=3, kkk
17845 !el      real(kind=8) :: dist
17846       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17847       logical :: lprn=.false.
17848       logical :: flag
17849       real(kind=8) :: sim,dd0,fac,ddqij
17850 !el      sigm(x)=0.25d0*x           ! local function
17851       do kkk=1,nperm
17852       do i=0,nres
17853       do j=1,3
17854         dqwol(j,i)=0.0d0
17855         dxqwol(j,i)=0.0d0
17856       enddo
17857       enddo
17858       nl=0
17859        if(flag) then
17860       do il=seg1+nsep,seg2
17861         do jl=seg1,il-nsep
17862           nl=nl+1
17863           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17864                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17865                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17866           dij=dist(il,jl)
17867           sim = 1.0d0/sigm(d0ij)
17868           sim = sim*sim
17869           dd0 = dij-d0ij
17870           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17871         do k=1,3
17872             ddqij = (c(k,il)-c(k,jl))*fac
17873             dqwol(k,il)=dqwol(k,il)+ddqij
17874             dqwol(k,jl)=dqwol(k,jl)-ddqij
17875           enddo
17876
17877           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17878             nl=nl+1
17879             d0ijCM=dsqrt( &
17880                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17881                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17882                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17883             dijCM=dist(il+nres,jl+nres)
17884             sim = 1.0d0/sigm(d0ijCM)
17885             sim = sim*sim
17886             dd0=dijCM-d0ijCM
17887             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17888             do k=1,3
17889             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17890             dxqwol(k,il)=dxqwol(k,il)+ddqij
17891             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17892             enddo
17893           endif
17894         enddo
17895       enddo
17896        else
17897       do il=seg1,seg2
17898       if((seg3-il).lt.3) then
17899            secseg=il+3
17900       else
17901            secseg=seg3
17902       endif
17903         do jl=secseg,seg4
17904           nl=nl+1
17905           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17906                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17907                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17908           dij=dist(il,jl)
17909           sim = 1.0d0/sigm(d0ij)
17910           sim = sim*sim
17911           dd0 = dij-d0ij
17912           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17913           do k=1,3
17914             ddqij = (c(k,il)-c(k,jl))*fac
17915             dqwol(k,il)=dqwol(k,il)+ddqij
17916             dqwol(k,jl)=dqwol(k,jl)-ddqij
17917           enddo
17918           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17919             nl=nl+1
17920             d0ijCM=dsqrt( &
17921                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17922                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17923                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17924             dijCM=dist(il+nres,jl+nres)
17925             sim = 1.0d0/sigm(d0ijCM)
17926             sim=sim*sim
17927             dd0 = dijCM-d0ijCM
17928             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17929             do k=1,3
17930              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17931              dxqwol(k,il)=dxqwol(k,il)+ddqij
17932              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17933             enddo
17934           endif
17935         enddo
17936       enddo
17937       endif
17938       enddo
17939        do i=0,nres
17940        do j=1,3
17941          dqwol(j,i)=dqwol(j,i)/nl
17942          dxqwol(j,i)=dxqwol(j,i)/nl
17943        enddo
17944        enddo
17945       return
17946       end subroutine qwolynes_prim
17947 !-----------------------------------------------------------------------------
17948       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17949 !      implicit real*8 (a-h,o-z)
17950 !      include 'DIMENSIONS'
17951 !      include 'COMMON.IOUNITS'
17952 !      include 'COMMON.CHAIN'
17953 !      include 'COMMON.INTERACT'
17954 !      include 'COMMON.VAR'
17955       integer :: seg1,seg2,seg3,seg4
17956       logical :: flag
17957       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17958       real(kind=8),dimension(3,0:2*nres) :: cdummy
17959       real(kind=8) :: q1,q2
17960       real(kind=8) :: delta=1.0d-10
17961       integer :: i,j
17962
17963       do i=0,nres
17964       do j=1,3
17965         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17966         cdummy(j,i)=c(j,i)
17967         c(j,i)=c(j,i)+delta
17968         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17969         qwolan(j,i)=(q2-q1)/delta
17970         c(j,i)=cdummy(j,i)
17971       enddo
17972       enddo
17973       do i=0,nres
17974       do j=1,3
17975         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17976         cdummy(j,i+nres)=c(j,i+nres)
17977         c(j,i+nres)=c(j,i+nres)+delta
17978         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17979         qwolxan(j,i)=(q2-q1)/delta
17980         c(j,i+nres)=cdummy(j,i+nres)
17981       enddo
17982       enddo
17983 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17984 !      do i=0,nct
17985 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17986 !      enddo
17987 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17988 !      do i=0,nct
17989 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17990 !      enddo
17991       return
17992       end subroutine qwol_num
17993 !-----------------------------------------------------------------------------
17994       subroutine EconstrQ
17995 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17996 !      implicit real*8 (a-h,o-z)
17997 !      include 'DIMENSIONS'
17998 !      include 'COMMON.CONTROL'
17999 !      include 'COMMON.VAR'
18000 !      include 'COMMON.MD'
18001       use MD_data
18002 !#ifndef LANG0
18003 !      include 'COMMON.LANGEVIN'
18004 !#else
18005 !      include 'COMMON.LANGEVIN.lang0'
18006 !#endif
18007 !      include 'COMMON.CHAIN'
18008 !      include 'COMMON.DERIV'
18009 !      include 'COMMON.GEO'
18010 !      include 'COMMON.LOCAL'
18011 !      include 'COMMON.INTERACT'
18012 !      include 'COMMON.IOUNITS'
18013 !      include 'COMMON.NAMES'
18014 !      include 'COMMON.TIME1'
18015       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18016       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18017                duconst,duxconst
18018       integer :: kstart,kend,lstart,lend,idummy
18019       real(kind=8) :: delta=1.0d-7
18020       integer :: i,j,k,ii
18021       do i=0,nres
18022        do j=1,3
18023           duconst(j,i)=0.0d0
18024           dudconst(j,i)=0.0d0
18025           duxconst(j,i)=0.0d0
18026           dudxconst(j,i)=0.0d0
18027        enddo
18028       enddo
18029       Uconst=0.0d0
18030       do i=1,nfrag
18031        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18032          idummy,idummy)
18033        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18034 ! Calculating the derivatives of Constraint energy with respect to Q
18035        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18036          qinfrag(i,iset))
18037 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18038 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18039 !         hmnum=(hm2-hm1)/delta
18040 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18041 !     &   qinfrag(i,iset))
18042 !         write(iout,*) "harmonicnum frag", hmnum
18043 ! Calculating the derivatives of Q with respect to cartesian coordinates
18044        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18045         idummy,idummy)
18046 !         write(iout,*) "dqwol "
18047 !         do ii=1,nres
18048 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18049 !         enddo
18050 !         write(iout,*) "dxqwol "
18051 !         do ii=1,nres
18052 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18053 !         enddo
18054 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18055 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18056 !     &  ,idummy,idummy)
18057 !  The gradients of Uconst in Cs
18058        do ii=0,nres
18059           do j=1,3
18060              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18061              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18062           enddo
18063        enddo
18064       enddo
18065       do i=1,npair
18066        kstart=ifrag(1,ipair(1,i,iset),iset)
18067        kend=ifrag(2,ipair(1,i,iset),iset)
18068        lstart=ifrag(1,ipair(2,i,iset),iset)
18069        lend=ifrag(2,ipair(2,i,iset),iset)
18070        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18071        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18072 !  Calculating dU/dQ
18073        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18074 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18075 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18076 !         hmnum=(hm2-hm1)/delta
18077 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18078 !     &   qinpair(i,iset))
18079 !         write(iout,*) "harmonicnum pair ", hmnum
18080 ! Calculating dQ/dXi
18081        call qwolynes_prim(kstart,kend,.false.,&
18082         lstart,lend)
18083 !         write(iout,*) "dqwol "
18084 !         do ii=1,nres
18085 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18086 !         enddo
18087 !         write(iout,*) "dxqwol "
18088 !         do ii=1,nres
18089 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18090 !        enddo
18091 ! Calculating numerical gradients
18092 !        call qwol_num(kstart,kend,.false.
18093 !     &  ,lstart,lend)
18094 ! The gradients of Uconst in Cs
18095        do ii=0,nres
18096           do j=1,3
18097              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18098              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18099           enddo
18100        enddo
18101       enddo
18102 !      write(iout,*) "Uconst inside subroutine ", Uconst
18103 ! Transforming the gradients from Cs to dCs for the backbone
18104       do i=0,nres
18105        do j=i+1,nres
18106          do k=1,3
18107            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18108          enddo
18109        enddo
18110       enddo
18111 !  Transforming the gradients from Cs to dCs for the side chains
18112       do i=1,nres
18113        do j=1,3
18114          dudxconst(j,i)=duxconst(j,i)
18115        enddo
18116       enddo
18117 !      write(iout,*) "dU/ddc backbone "
18118 !       do ii=0,nres
18119 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18120 !      enddo
18121 !      write(iout,*) "dU/ddX side chain "
18122 !      do ii=1,nres
18123 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18124 !      enddo
18125 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18126 !      call dEconstrQ_num
18127       return
18128       end subroutine EconstrQ
18129 !-----------------------------------------------------------------------------
18130       subroutine dEconstrQ_num
18131 ! Calculating numerical dUconst/ddc and dUconst/ddx
18132 !      implicit real*8 (a-h,o-z)
18133 !      include 'DIMENSIONS'
18134 !      include 'COMMON.CONTROL'
18135 !      include 'COMMON.VAR'
18136 !      include 'COMMON.MD'
18137       use MD_data
18138 !#ifndef LANG0
18139 !      include 'COMMON.LANGEVIN'
18140 !#else
18141 !      include 'COMMON.LANGEVIN.lang0'
18142 !#endif
18143 !      include 'COMMON.CHAIN'
18144 !      include 'COMMON.DERIV'
18145 !      include 'COMMON.GEO'
18146 !      include 'COMMON.LOCAL'
18147 !      include 'COMMON.INTERACT'
18148 !      include 'COMMON.IOUNITS'
18149 !      include 'COMMON.NAMES'
18150 !      include 'COMMON.TIME1'
18151       real(kind=8) :: uzap1,uzap2
18152       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18153       integer :: kstart,kend,lstart,lend,idummy
18154       real(kind=8) :: delta=1.0d-7
18155 !el local variables
18156       integer :: i,ii,j
18157 !     real(kind=8) ::
18158 !     For the backbone
18159       do i=0,nres-1
18160        do j=1,3
18161           dUcartan(j,i)=0.0d0
18162           cdummy(j,i)=dc(j,i)
18163           dc(j,i)=dc(j,i)+delta
18164           call chainbuild_cart
18165         uzap2=0.0d0
18166           do ii=1,nfrag
18167            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18168             idummy,idummy)
18169              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18170             qinfrag(ii,iset))
18171           enddo
18172           do ii=1,npair
18173              kstart=ifrag(1,ipair(1,ii,iset),iset)
18174              kend=ifrag(2,ipair(1,ii,iset),iset)
18175              lstart=ifrag(1,ipair(2,ii,iset),iset)
18176              lend=ifrag(2,ipair(2,ii,iset),iset)
18177              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18178              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18179              qinpair(ii,iset))
18180           enddo
18181           dc(j,i)=cdummy(j,i)
18182           call chainbuild_cart
18183           uzap1=0.0d0
18184            do ii=1,nfrag
18185            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18186             idummy,idummy)
18187              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18188             qinfrag(ii,iset))
18189           enddo
18190           do ii=1,npair
18191              kstart=ifrag(1,ipair(1,ii,iset),iset)
18192              kend=ifrag(2,ipair(1,ii,iset),iset)
18193              lstart=ifrag(1,ipair(2,ii,iset),iset)
18194              lend=ifrag(2,ipair(2,ii,iset),iset)
18195              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18196              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18197             qinpair(ii,iset))
18198           enddo
18199           ducartan(j,i)=(uzap2-uzap1)/(delta)
18200        enddo
18201       enddo
18202 ! Calculating numerical gradients for dU/ddx
18203       do i=0,nres-1
18204        duxcartan(j,i)=0.0d0
18205        do j=1,3
18206           cdummy(j,i)=dc(j,i+nres)
18207           dc(j,i+nres)=dc(j,i+nres)+delta
18208           call chainbuild_cart
18209         uzap2=0.0d0
18210           do ii=1,nfrag
18211            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18212             idummy,idummy)
18213              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18214             qinfrag(ii,iset))
18215           enddo
18216           do ii=1,npair
18217              kstart=ifrag(1,ipair(1,ii,iset),iset)
18218              kend=ifrag(2,ipair(1,ii,iset),iset)
18219              lstart=ifrag(1,ipair(2,ii,iset),iset)
18220              lend=ifrag(2,ipair(2,ii,iset),iset)
18221              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18222              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18223             qinpair(ii,iset))
18224           enddo
18225           dc(j,i+nres)=cdummy(j,i)
18226           call chainbuild_cart
18227           uzap1=0.0d0
18228            do ii=1,nfrag
18229              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18230             ifrag(2,ii,iset),.true.,idummy,idummy)
18231              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18232             qinfrag(ii,iset))
18233           enddo
18234           do ii=1,npair
18235              kstart=ifrag(1,ipair(1,ii,iset),iset)
18236              kend=ifrag(2,ipair(1,ii,iset),iset)
18237              lstart=ifrag(1,ipair(2,ii,iset),iset)
18238              lend=ifrag(2,ipair(2,ii,iset),iset)
18239              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18240              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18241             qinpair(ii,iset))
18242           enddo
18243           duxcartan(j,i)=(uzap2-uzap1)/(delta)
18244        enddo
18245       enddo
18246       write(iout,*) "Numerical dUconst/ddc backbone "
18247       do ii=0,nres
18248       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18249       enddo
18250 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18251 !      do ii=1,nres
18252 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18253 !      enddo
18254       return
18255       end subroutine dEconstrQ_num
18256 !-----------------------------------------------------------------------------
18257 ! ssMD.F
18258 !-----------------------------------------------------------------------------
18259       subroutine check_energies
18260
18261 !      use random, only: ran_number
18262
18263 !      implicit none
18264 !     Includes
18265 !      include 'DIMENSIONS'
18266 !      include 'COMMON.CHAIN'
18267 !      include 'COMMON.VAR'
18268 !      include 'COMMON.IOUNITS'
18269 !      include 'COMMON.SBRIDGE'
18270 !      include 'COMMON.LOCAL'
18271 !      include 'COMMON.GEO'
18272
18273 !     External functions
18274 !EL      double precision ran_number
18275 !EL      external ran_number
18276
18277 !     Local variables
18278       integer :: i,j,k,l,lmax,p,pmax
18279       real(kind=8) :: rmin,rmax
18280       real(kind=8) :: eij
18281
18282       real(kind=8) :: d
18283       real(kind=8) :: wi,rij,tj,pj
18284 !      return
18285
18286       i=5
18287       j=14
18288
18289       d=dsc(1)
18290       rmin=2.0D0
18291       rmax=12.0D0
18292
18293       lmax=10000
18294       pmax=1
18295
18296       do k=1,3
18297       c(k,i)=0.0D0
18298       c(k,j)=0.0D0
18299       c(k,nres+i)=0.0D0
18300       c(k,nres+j)=0.0D0
18301       enddo
18302
18303       do l=1,lmax
18304
18305 !t        wi=ran_number(0.0D0,pi)
18306 !        wi=ran_number(0.0D0,pi/6.0D0)
18307 !        wi=0.0D0
18308 !t        tj=ran_number(0.0D0,pi)
18309 !t        pj=ran_number(0.0D0,pi)
18310 !        pj=ran_number(0.0D0,pi/6.0D0)
18311 !        pj=0.0D0
18312
18313       do p=1,pmax
18314 !t           rij=ran_number(rmin,rmax)
18315
18316          c(1,j)=d*sin(pj)*cos(tj)
18317          c(2,j)=d*sin(pj)*sin(tj)
18318          c(3,j)=d*cos(pj)
18319
18320          c(3,nres+i)=-rij
18321
18322          c(1,i)=d*sin(wi)
18323          c(3,i)=-rij-d*cos(wi)
18324
18325          do k=1,3
18326             dc(k,nres+i)=c(k,nres+i)-c(k,i)
18327             dc_norm(k,nres+i)=dc(k,nres+i)/d
18328             dc(k,nres+j)=c(k,nres+j)-c(k,j)
18329             dc_norm(k,nres+j)=dc(k,nres+j)/d
18330          enddo
18331
18332          call dyn_ssbond_ene(i,j,eij)
18333       enddo
18334       enddo
18335       call exit(1)
18336       return
18337       end subroutine check_energies
18338 !-----------------------------------------------------------------------------
18339       subroutine dyn_ssbond_ene(resi,resj,eij)
18340 !      implicit none
18341 !      Includes
18342       use calc_data
18343       use comm_sschecks
18344 !      include 'DIMENSIONS'
18345 !      include 'COMMON.SBRIDGE'
18346 !      include 'COMMON.CHAIN'
18347 !      include 'COMMON.DERIV'
18348 !      include 'COMMON.LOCAL'
18349 !      include 'COMMON.INTERACT'
18350 !      include 'COMMON.VAR'
18351 !      include 'COMMON.IOUNITS'
18352 !      include 'COMMON.CALC'
18353 #ifndef CLUST
18354 #ifndef WHAM
18355        use MD_data
18356 !      include 'COMMON.MD'
18357 !      use MD, only: totT,t_bath
18358 #endif
18359 #endif
18360 !     External functions
18361 !EL      double precision h_base
18362 !EL      external h_base
18363
18364 !     Input arguments
18365       integer :: resi,resj
18366
18367 !     Output arguments
18368       real(kind=8) :: eij
18369
18370 !     Local variables
18371       logical :: havebond
18372       integer itypi,itypj
18373       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18374       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18375       real(kind=8),dimension(3) :: dcosom1,dcosom2
18376       real(kind=8) :: ed
18377       real(kind=8) :: pom1,pom2
18378       real(kind=8) :: ljA,ljB,ljXs
18379       real(kind=8),dimension(1:3) :: d_ljB
18380       real(kind=8) :: ssA,ssB,ssC,ssXs
18381       real(kind=8) :: ssxm,ljxm,ssm,ljm
18382       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18383       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18384       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18385 !-------FIRST METHOD
18386       real(kind=8) :: xm
18387       real(kind=8),dimension(1:3) :: d_xm
18388 !-------END FIRST METHOD
18389 !-------SECOND METHOD
18390 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18391 !-------END SECOND METHOD
18392
18393 !-------TESTING CODE
18394 !el      logical :: checkstop,transgrad
18395 !el      common /sschecks/ checkstop,transgrad
18396
18397       integer :: icheck,nicheck,jcheck,njcheck
18398       real(kind=8),dimension(-1:1) :: echeck
18399       real(kind=8) :: deps,ssx0,ljx0
18400 !-------END TESTING CODE
18401
18402       eij=0.0d0
18403       i=resi
18404       j=resj
18405
18406 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18407 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18408
18409       itypi=itype(i,1)
18410       dxi=dc_norm(1,nres+i)
18411       dyi=dc_norm(2,nres+i)
18412       dzi=dc_norm(3,nres+i)
18413       dsci_inv=vbld_inv(i+nres)
18414
18415       itypj=itype(j,1)
18416       xj=c(1,nres+j)-c(1,nres+i)
18417       yj=c(2,nres+j)-c(2,nres+i)
18418       zj=c(3,nres+j)-c(3,nres+i)
18419       dxj=dc_norm(1,nres+j)
18420       dyj=dc_norm(2,nres+j)
18421       dzj=dc_norm(3,nres+j)
18422       dscj_inv=vbld_inv(j+nres)
18423
18424       chi1=chi(itypi,itypj)
18425       chi2=chi(itypj,itypi)
18426       chi12=chi1*chi2
18427       chip1=chip(itypi)
18428       chip2=chip(itypj)
18429       chip12=chip1*chip2
18430       alf1=alp(itypi)
18431       alf2=alp(itypj)
18432       alf12=0.5D0*(alf1+alf2)
18433
18434       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18435       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18436 !     The following are set in sc_angular
18437 !      erij(1)=xj*rij
18438 !      erij(2)=yj*rij
18439 !      erij(3)=zj*rij
18440 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18441 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18442 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18443       call sc_angular
18444       rij=1.0D0/rij  ! Reset this so it makes sense
18445
18446       sig0ij=sigma(itypi,itypj)
18447       sig=sig0ij*dsqrt(1.0D0/sigsq)
18448
18449       ljXs=sig-sig0ij
18450       ljA=eps1*eps2rt**2*eps3rt**2
18451       ljB=ljA*bb_aq(itypi,itypj)
18452       ljA=ljA*aa_aq(itypi,itypj)
18453       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18454
18455       ssXs=d0cm
18456       deltat1=1.0d0-om1
18457       deltat2=1.0d0+om2
18458       deltat12=om2-om1+2.0d0
18459       cosphi=om12-om1*om2
18460       ssA=akcm
18461       ssB=akct*deltat12
18462       ssC=ss_depth &
18463          +akth*(deltat1*deltat1+deltat2*deltat2) &
18464          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18465       ssxm=ssXs-0.5D0*ssB/ssA
18466
18467 !-------TESTING CODE
18468 !$$$c     Some extra output
18469 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18470 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18471 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18472 !$$$      if (ssx0.gt.0.0d0) then
18473 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18474 !$$$      else
18475 !$$$        ssx0=ssxm
18476 !$$$      endif
18477 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18478 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18479 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18480 !$$$      return
18481 !-------END TESTING CODE
18482
18483 !-------TESTING CODE
18484 !     Stop and plot energy and derivative as a function of distance
18485       if (checkstop) then
18486       ssm=ssC-0.25D0*ssB*ssB/ssA
18487       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18488       if (ssm.lt.ljm .and. &
18489            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18490         nicheck=1000
18491         njcheck=1
18492         deps=0.5d-7
18493       else
18494         checkstop=.false.
18495       endif
18496       endif
18497       if (.not.checkstop) then
18498       nicheck=0
18499       njcheck=-1
18500       endif
18501
18502       do icheck=0,nicheck
18503       do jcheck=-1,njcheck
18504       if (checkstop) rij=(ssxm-1.0d0)+ &
18505            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18506 !-------END TESTING CODE
18507
18508       if (rij.gt.ljxm) then
18509       havebond=.false.
18510       ljd=rij-ljXs
18511       fac=(1.0D0/ljd)**expon
18512       e1=fac*fac*aa_aq(itypi,itypj)
18513       e2=fac*bb_aq(itypi,itypj)
18514       eij=eps1*eps2rt*eps3rt*(e1+e2)
18515       eps2der=eij*eps3rt
18516       eps3der=eij*eps2rt
18517       eij=eij*eps2rt*eps3rt
18518
18519       sigder=-sig/sigsq
18520       e1=e1*eps1*eps2rt**2*eps3rt**2
18521       ed=-expon*(e1+eij)/ljd
18522       sigder=ed*sigder
18523       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18524       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18525       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18526            -2.0D0*alf12*eps3der+sigder*sigsq_om12
18527       else if (rij.lt.ssxm) then
18528       havebond=.true.
18529       ssd=rij-ssXs
18530       eij=ssA*ssd*ssd+ssB*ssd+ssC
18531
18532       ed=2*akcm*ssd+akct*deltat12
18533       pom1=akct*ssd
18534       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18535       eom1=-2*akth*deltat1-pom1-om2*pom2
18536       eom2= 2*akth*deltat2+pom1-om1*pom2
18537       eom12=pom2
18538       else
18539       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18540
18541       d_ssxm(1)=0.5D0*akct/ssA
18542       d_ssxm(2)=-d_ssxm(1)
18543       d_ssxm(3)=0.0D0
18544
18545       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18546       d_ljxm(2)=d_ljxm(1)*sigsq_om2
18547       d_ljxm(3)=d_ljxm(1)*sigsq_om12
18548       d_ljxm(1)=d_ljxm(1)*sigsq_om1
18549
18550 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18551       xm=0.5d0*(ssxm+ljxm)
18552       do k=1,3
18553         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18554       enddo
18555       if (rij.lt.xm) then
18556         havebond=.true.
18557         ssm=ssC-0.25D0*ssB*ssB/ssA
18558         d_ssm(1)=0.5D0*akct*ssB/ssA
18559         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18560         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18561         d_ssm(3)=omega
18562         f1=(rij-xm)/(ssxm-xm)
18563         f2=(rij-ssxm)/(xm-ssxm)
18564         h1=h_base(f1,hd1)
18565         h2=h_base(f2,hd2)
18566         eij=ssm*h1+Ht*h2
18567         delta_inv=1.0d0/(xm-ssxm)
18568         deltasq_inv=delta_inv*delta_inv
18569         fac=ssm*hd1-Ht*hd2
18570         fac1=deltasq_inv*fac*(xm-rij)
18571         fac2=deltasq_inv*fac*(rij-ssxm)
18572         ed=delta_inv*(Ht*hd2-ssm*hd1)
18573         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18574         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18575         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18576       else
18577         havebond=.false.
18578         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18579         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18580         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18581         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18582              alf12/eps3rt)
18583         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18584         f1=(rij-ljxm)/(xm-ljxm)
18585         f2=(rij-xm)/(ljxm-xm)
18586         h1=h_base(f1,hd1)
18587         h2=h_base(f2,hd2)
18588         eij=Ht*h1+ljm*h2
18589         delta_inv=1.0d0/(ljxm-xm)
18590         deltasq_inv=delta_inv*delta_inv
18591         fac=Ht*hd1-ljm*hd2
18592         fac1=deltasq_inv*fac*(ljxm-rij)
18593         fac2=deltasq_inv*fac*(rij-xm)
18594         ed=delta_inv*(ljm*hd2-Ht*hd1)
18595         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18596         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18597         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18598       endif
18599 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18600
18601 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18602 !$$$        ssd=rij-ssXs
18603 !$$$        ljd=rij-ljXs
18604 !$$$        fac1=rij-ljxm
18605 !$$$        fac2=rij-ssxm
18606 !$$$
18607 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18608 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18609 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18610 !$$$
18611 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18612 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18613 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18614 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18615 !$$$        d_ssm(3)=omega
18616 !$$$
18617 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18618 !$$$        do k=1,3
18619 !$$$          d_ljm(k)=ljm*d_ljB(k)
18620 !$$$        enddo
18621 !$$$        ljm=ljm*ljB
18622 !$$$
18623 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18624 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18625 !$$$        d_ss(2)=akct*ssd
18626 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18627 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18628 !$$$        d_ss(3)=omega
18629 !$$$
18630 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18631 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18632 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18633 !$$$        do k=1,3
18634 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18635 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18636 !$$$        enddo
18637 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18638 !$$$
18639 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18640 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18641 !$$$        h1=h_base(f1,hd1)
18642 !$$$        h2=h_base(f2,hd2)
18643 !$$$        eij=ss*h1+ljf*h2
18644 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18645 !$$$        deltasq_inv=delta_inv*delta_inv
18646 !$$$        fac=ljf*hd2-ss*hd1
18647 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18648 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18649 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18650 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18651 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18652 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18653 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18654 !$$$
18655 !$$$        havebond=.false.
18656 !$$$        if (ed.gt.0.0d0) havebond=.true.
18657 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18658
18659       endif
18660
18661       if (havebond) then
18662 !#ifndef CLUST
18663 !#ifndef WHAM
18664 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18665 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18666 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18667 !        endif
18668 !#endif
18669 !#endif
18670       dyn_ssbond_ij(i,j)=eij
18671       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18672       dyn_ssbond_ij(i,j)=1.0d300
18673 !#ifndef CLUST
18674 !#ifndef WHAM
18675 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18676 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18677 !#endif
18678 !#endif
18679       endif
18680
18681 !-------TESTING CODE
18682 !el      if (checkstop) then
18683       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18684            "CHECKSTOP",rij,eij,ed
18685       echeck(jcheck)=eij
18686 !el      endif
18687       enddo
18688       if (checkstop) then
18689       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18690       endif
18691       enddo
18692       if (checkstop) then
18693       transgrad=.true.
18694       checkstop=.false.
18695       endif
18696 !-------END TESTING CODE
18697
18698       do k=1,3
18699       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18700       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18701       enddo
18702       do k=1,3
18703       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18704       enddo
18705       do k=1,3
18706       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18707            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18708            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18709       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18710            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18711            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18712       enddo
18713 !grad      do k=i,j-1
18714 !grad        do l=1,3
18715 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18716 !grad        enddo
18717 !grad      enddo
18718
18719       do l=1,3
18720       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18721       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18722       enddo
18723
18724       return
18725       end subroutine dyn_ssbond_ene
18726 !--------------------------------------------------------------------------
18727        subroutine triple_ssbond_ene(resi,resj,resk,eij)
18728 !      implicit none
18729 !      Includes
18730       use calc_data
18731       use comm_sschecks
18732 !      include 'DIMENSIONS'
18733 !      include 'COMMON.SBRIDGE'
18734 !      include 'COMMON.CHAIN'
18735 !      include 'COMMON.DERIV'
18736 !      include 'COMMON.LOCAL'
18737 !      include 'COMMON.INTERACT'
18738 !      include 'COMMON.VAR'
18739 !      include 'COMMON.IOUNITS'
18740 !      include 'COMMON.CALC'
18741 #ifndef CLUST
18742 #ifndef WHAM
18743        use MD_data
18744 !      include 'COMMON.MD'
18745 !      use MD, only: totT,t_bath
18746 #endif
18747 #endif
18748       double precision h_base
18749       external h_base
18750
18751 !c     Input arguments
18752       integer resi,resj,resk,m,itypi,itypj,itypk
18753
18754 !c     Output arguments
18755       double precision eij,eij1,eij2,eij3
18756
18757 !c     Local variables
18758       logical havebond
18759 !c      integer itypi,itypj,k,l
18760       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18761       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18762       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18763       double precision sig0ij,ljd,sig,fac,e1,e2
18764       double precision dcosom1(3),dcosom2(3),ed
18765       double precision pom1,pom2
18766       double precision ljA,ljB,ljXs
18767       double precision d_ljB(1:3)
18768       double precision ssA,ssB,ssC,ssXs
18769       double precision ssxm,ljxm,ssm,ljm
18770       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18771       eij=0.0
18772       if (dtriss.eq.0) return
18773       i=resi
18774       j=resj
18775       k=resk
18776 !C      write(iout,*) resi,resj,resk
18777       itypi=itype(i,1)
18778       dxi=dc_norm(1,nres+i)
18779       dyi=dc_norm(2,nres+i)
18780       dzi=dc_norm(3,nres+i)
18781       dsci_inv=vbld_inv(i+nres)
18782       xi=c(1,nres+i)
18783       yi=c(2,nres+i)
18784       zi=c(3,nres+i)
18785       call to_box(xi,yi,zi)
18786       itypj=itype(j,1)
18787       xj=c(1,nres+j)
18788       yj=c(2,nres+j)
18789       zj=c(3,nres+j)
18790       call to_box(xj,yj,zj)
18791       dxj=dc_norm(1,nres+j)
18792       dyj=dc_norm(2,nres+j)
18793       dzj=dc_norm(3,nres+j)
18794       dscj_inv=vbld_inv(j+nres)
18795       itypk=itype(k,1)
18796       xk=c(1,nres+k)
18797       yk=c(2,nres+k)
18798       zk=c(3,nres+k)
18799        call to_box(xk,yk,zk)
18800       dxk=dc_norm(1,nres+k)
18801       dyk=dc_norm(2,nres+k)
18802       dzk=dc_norm(3,nres+k)
18803       dscj_inv=vbld_inv(k+nres)
18804       xij=xj-xi
18805       xik=xk-xi
18806       xjk=xk-xj
18807       yij=yj-yi
18808       yik=yk-yi
18809       yjk=yk-yj
18810       zij=zj-zi
18811       zik=zk-zi
18812       zjk=zk-zj
18813       rrij=(xij*xij+yij*yij+zij*zij)
18814       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18815       rrik=(xik*xik+yik*yik+zik*zik)
18816       rik=dsqrt(rrik)
18817       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18818       rjk=dsqrt(rrjk)
18819 !C there are three combination of distances for each trisulfide bonds
18820 !C The first case the ith atom is the center
18821 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18822 !C distance y is second distance the a,b,c,d are parameters derived for
18823 !C this problem d parameter was set as a penalty currenlty set to 1.
18824       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18825       eij1=0.0d0
18826       else
18827       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18828       endif
18829 !C second case jth atom is center
18830       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18831       eij2=0.0d0
18832       else
18833       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18834       endif
18835 !C the third case kth atom is the center
18836       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18837       eij3=0.0d0
18838       else
18839       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18840       endif
18841 !C      eij2=0.0
18842 !C      eij3=0.0
18843 !C      eij1=0.0
18844       eij=eij1+eij2+eij3
18845 !C      write(iout,*)i,j,k,eij
18846 !C The energy penalty calculated now time for the gradient part
18847 !C derivative over rij
18848       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18849       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18850           gg(1)=xij*fac/rij
18851           gg(2)=yij*fac/rij
18852           gg(3)=zij*fac/rij
18853       do m=1,3
18854       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18855       gvdwx(m,j)=gvdwx(m,j)+gg(m)
18856       enddo
18857
18858       do l=1,3
18859       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18860       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18861       enddo
18862 !C now derivative over rik
18863       fac=-eij1**2/dtriss* &
18864       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18865       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18866           gg(1)=xik*fac/rik
18867           gg(2)=yik*fac/rik
18868           gg(3)=zik*fac/rik
18869       do m=1,3
18870       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18871       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18872       enddo
18873       do l=1,3
18874       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18875       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18876       enddo
18877 !C now derivative over rjk
18878       fac=-eij2**2/dtriss* &
18879       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18880       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18881           gg(1)=xjk*fac/rjk
18882           gg(2)=yjk*fac/rjk
18883           gg(3)=zjk*fac/rjk
18884       do m=1,3
18885       gvdwx(m,j)=gvdwx(m,j)-gg(m)
18886       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18887       enddo
18888       do l=1,3
18889       gvdwc(l,j)=gvdwc(l,j)-gg(l)
18890       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18891       enddo
18892       return
18893       end subroutine triple_ssbond_ene
18894
18895
18896
18897 !-----------------------------------------------------------------------------
18898       real(kind=8) function h_base(x,deriv)
18899 !     A smooth function going 0->1 in range [0,1]
18900 !     It should NOT be called outside range [0,1], it will not work there.
18901       implicit none
18902
18903 !     Input arguments
18904       real(kind=8) :: x
18905
18906 !     Output arguments
18907       real(kind=8) :: deriv
18908
18909 !     Local variables
18910       real(kind=8) :: xsq
18911
18912
18913 !     Two parabolas put together.  First derivative zero at extrema
18914 !$$$      if (x.lt.0.5D0) then
18915 !$$$        h_base=2.0D0*x*x
18916 !$$$        deriv=4.0D0*x
18917 !$$$      else
18918 !$$$        deriv=1.0D0-x
18919 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18920 !$$$        deriv=4.0D0*deriv
18921 !$$$      endif
18922
18923 !     Third degree polynomial.  First derivative zero at extrema
18924       h_base=x*x*(3.0d0-2.0d0*x)
18925       deriv=6.0d0*x*(1.0d0-x)
18926
18927 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18928 !$$$      xsq=x*x
18929 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18930 !$$$      deriv=x-1.0d0
18931 !$$$      deriv=deriv*deriv
18932 !$$$      deriv=30.0d0*xsq*deriv
18933
18934       return
18935       end function h_base
18936 !-----------------------------------------------------------------------------
18937       subroutine dyn_set_nss
18938 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18939 !      implicit none
18940       use MD_data, only: totT,t_bath
18941 !     Includes
18942 !      include 'DIMENSIONS'
18943 #ifdef MPI
18944       include "mpif.h"
18945 #endif
18946 !      include 'COMMON.SBRIDGE'
18947 !      include 'COMMON.CHAIN'
18948 !      include 'COMMON.IOUNITS'
18949 !      include 'COMMON.SETUP'
18950 !      include 'COMMON.MD'
18951 !     Local variables
18952       real(kind=8) :: emin
18953       integer :: i,j,imin,ierr
18954       integer :: diff,allnss,newnss
18955       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18956             newihpb,newjhpb
18957       logical :: found
18958       integer,dimension(0:nfgtasks) :: i_newnss
18959       integer,dimension(0:nfgtasks) :: displ
18960       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18961       integer :: g_newnss
18962
18963       allnss=0
18964       do i=1,nres-1
18965       do j=i+1,nres
18966         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18967           allnss=allnss+1
18968           allflag(allnss)=0
18969           allihpb(allnss)=i
18970           alljhpb(allnss)=j
18971         endif
18972       enddo
18973       enddo
18974
18975 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18976
18977  1    emin=1.0d300
18978       do i=1,allnss
18979       if (allflag(i).eq.0 .and. &
18980            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18981         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18982         imin=i
18983       endif
18984       enddo
18985       if (emin.lt.1.0d300) then
18986       allflag(imin)=1
18987       do i=1,allnss
18988         if (allflag(i).eq.0 .and. &
18989              (allihpb(i).eq.allihpb(imin) .or. &
18990              alljhpb(i).eq.allihpb(imin) .or. &
18991              allihpb(i).eq.alljhpb(imin) .or. &
18992              alljhpb(i).eq.alljhpb(imin))) then
18993           allflag(i)=-1
18994         endif
18995       enddo
18996       goto 1
18997       endif
18998
18999 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19000
19001       newnss=0
19002       do i=1,allnss
19003       if (allflag(i).eq.1) then
19004         newnss=newnss+1
19005         newihpb(newnss)=allihpb(i)
19006         newjhpb(newnss)=alljhpb(i)
19007       endif
19008       enddo
19009
19010 #ifdef MPI
19011       if (nfgtasks.gt.1)then
19012
19013       call MPI_Reduce(newnss,g_newnss,1,&
19014         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19015       call MPI_Gather(newnss,1,MPI_INTEGER,&
19016                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19017       displ(0)=0
19018       do i=1,nfgtasks-1,1
19019         displ(i)=i_newnss(i-1)+displ(i-1)
19020       enddo
19021       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19022                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19023                    king,FG_COMM,IERR)
19024       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19025                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19026                    king,FG_COMM,IERR)
19027       if(fg_rank.eq.0) then
19028 !         print *,'g_newnss',g_newnss
19029 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19030 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19031        newnss=g_newnss
19032        do i=1,newnss
19033         newihpb(i)=g_newihpb(i)
19034         newjhpb(i)=g_newjhpb(i)
19035        enddo
19036       endif
19037       endif
19038 #endif
19039
19040       diff=newnss-nss
19041
19042 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19043 !       print *,newnss,nss,maxdim
19044       do i=1,nss
19045       found=.false.
19046 !        print *,newnss
19047       do j=1,newnss
19048 !!          print *,j
19049         if (idssb(i).eq.newihpb(j) .and. &
19050              jdssb(i).eq.newjhpb(j)) found=.true.
19051       enddo
19052 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19053 !        write(iout,*) "found",found,i,j
19054       if (.not.found.and.fg_rank.eq.0) &
19055           write(iout,'(a15,f12.2,f8.1,2i5)') &
19056            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19057 #endif
19058       enddo
19059
19060       do i=1,newnss
19061       found=.false.
19062       do j=1,nss
19063 !          print *,i,j
19064         if (newihpb(i).eq.idssb(j) .and. &
19065              newjhpb(i).eq.jdssb(j)) found=.true.
19066       enddo
19067 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19068 !        write(iout,*) "found",found,i,j
19069       if (.not.found.and.fg_rank.eq.0) &
19070           write(iout,'(a15,f12.2,f8.1,2i5)') &
19071            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19072 #endif
19073       enddo
19074 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19075       nss=newnss
19076       do i=1,nss
19077       idssb(i)=newihpb(i)
19078       jdssb(i)=newjhpb(i)
19079       enddo
19080 !#else
19081 !      nss=0
19082 !#endif
19083
19084       return
19085       end subroutine dyn_set_nss
19086 ! Lipid transfer energy function
19087       subroutine Eliptransfer(eliptran)
19088 !C this is done by Adasko
19089 !C      print *,"wchodze"
19090 !C structure of box:
19091 !C      water
19092 !C--bordliptop-- buffore starts
19093 !C--bufliptop--- here true lipid starts
19094 !C      lipid
19095 !C--buflipbot--- lipid ends buffore starts
19096 !C--bordlipbot--buffore ends
19097       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19098       integer :: i
19099       eliptran=0.0
19100 !      print *, "I am in eliptran"
19101       do i=ilip_start,ilip_end
19102 !C       do i=1,1
19103       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19104        cycle
19105
19106       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19107       if (positi.le.0.0) positi=positi+boxzsize
19108 !C        print *,i
19109 !C first for peptide groups
19110 !c for each residue check if it is in lipid or lipid water border area
19111        if ((positi.gt.bordlipbot)  &
19112       .and.(positi.lt.bordliptop)) then
19113 !C the energy transfer exist
19114       if (positi.lt.buflipbot) then
19115 !C what fraction I am in
19116        fracinbuf=1.0d0-      &
19117            ((positi-bordlipbot)/lipbufthick)
19118 !C lipbufthick is thickenes of lipid buffore
19119        sslip=sscalelip(fracinbuf)
19120        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19121        eliptran=eliptran+sslip*pepliptran
19122        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19123        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19124 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19125
19126 !C        print *,"doing sccale for lower part"
19127 !C         print *,i,sslip,fracinbuf,ssgradlip
19128       elseif (positi.gt.bufliptop) then
19129        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19130        sslip=sscalelip(fracinbuf)
19131        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19132        eliptran=eliptran+sslip*pepliptran
19133        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19134        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19135 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19136 !C          print *, "doing sscalefor top part"
19137 !C         print *,i,sslip,fracinbuf,ssgradlip
19138       else
19139        eliptran=eliptran+pepliptran
19140 !C         print *,"I am in true lipid"
19141       endif
19142 !C       else
19143 !C       eliptran=elpitran+0.0 ! I am in water
19144        endif
19145        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19146        enddo
19147 ! here starts the side chain transfer
19148        do i=ilip_start,ilip_end
19149       if (itype(i,1).eq.ntyp1) cycle
19150       positi=(mod(c(3,i+nres),boxzsize))
19151       if (positi.le.0) positi=positi+boxzsize
19152 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19153 !c for each residue check if it is in lipid or lipid water border area
19154 !C       respos=mod(c(3,i+nres),boxzsize)
19155 !C       print *,positi,bordlipbot,buflipbot
19156        if ((positi.gt.bordlipbot) &
19157        .and.(positi.lt.bordliptop)) then
19158 !C the energy transfer exist
19159       if (positi.lt.buflipbot) then
19160        fracinbuf=1.0d0-   &
19161          ((positi-bordlipbot)/lipbufthick)
19162 !C lipbufthick is thickenes of lipid buffore
19163        sslip=sscalelip(fracinbuf)
19164        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19165        eliptran=eliptran+sslip*liptranene(itype(i,1))
19166        gliptranx(3,i)=gliptranx(3,i) &
19167       +ssgradlip*liptranene(itype(i,1))
19168        gliptranc(3,i-1)= gliptranc(3,i-1) &
19169       +ssgradlip*liptranene(itype(i,1))
19170 !C         print *,"doing sccale for lower part"
19171       elseif (positi.gt.bufliptop) then
19172        fracinbuf=1.0d0-  &
19173       ((bordliptop-positi)/lipbufthick)
19174        sslip=sscalelip(fracinbuf)
19175        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19176        eliptran=eliptran+sslip*liptranene(itype(i,1))
19177        gliptranx(3,i)=gliptranx(3,i)  &
19178        +ssgradlip*liptranene(itype(i,1))
19179        gliptranc(3,i-1)= gliptranc(3,i-1) &
19180       +ssgradlip*liptranene(itype(i,1))
19181 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19182       else
19183        eliptran=eliptran+liptranene(itype(i,1))
19184 !C         print *,"I am in true lipid"
19185       endif
19186       endif ! if in lipid or buffor
19187 !C       else
19188 !C       eliptran=elpitran+0.0 ! I am in water
19189       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19190        enddo
19191        return
19192        end  subroutine Eliptransfer
19193 !----------------------------------NANO FUNCTIONS
19194 !C-----------------------------------------------------------------------
19195 !C-----------------------------------------------------------
19196 !C This subroutine is to mimic the histone like structure but as well can be
19197 !C utilizet to nanostructures (infinit) small modification has to be used to
19198 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19199 !C gradient has to be modified at the ends
19200 !C The energy function is Kihara potential
19201 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19202 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19203 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19204 !C simple Kihara potential
19205       subroutine calctube(Etube)
19206       real(kind=8),dimension(3) :: vectube
19207       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19208        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19209        sc_aa_tube,sc_bb_tube
19210       integer :: i,j,iti
19211       Etube=0.0d0
19212       do i=itube_start,itube_end
19213       enetube(i)=0.0d0
19214       enetube(i+nres)=0.0d0
19215       enddo
19216 !C first we calculate the distance from tube center
19217 !C for UNRES
19218        do i=itube_start,itube_end
19219 !C lets ommit dummy atoms for now
19220        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19221 !C now calculate distance from center of tube and direction vectors
19222       xmin=boxxsize
19223       ymin=boxysize
19224 ! Find minimum distance in periodic box
19225       do j=-1,1
19226        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19227        vectube(1)=vectube(1)+boxxsize*j
19228        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19229        vectube(2)=vectube(2)+boxysize*j
19230        xminact=abs(vectube(1)-tubecenter(1))
19231        yminact=abs(vectube(2)-tubecenter(2))
19232          if (xmin.gt.xminact) then
19233           xmin=xminact
19234           xtemp=vectube(1)
19235          endif
19236          if (ymin.gt.yminact) then
19237            ymin=yminact
19238            ytemp=vectube(2)
19239           endif
19240        enddo
19241       vectube(1)=xtemp
19242       vectube(2)=ytemp
19243       vectube(1)=vectube(1)-tubecenter(1)
19244       vectube(2)=vectube(2)-tubecenter(2)
19245
19246 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19247 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19248
19249 !C as the tube is infinity we do not calculate the Z-vector use of Z
19250 !C as chosen axis
19251       vectube(3)=0.0d0
19252 !C now calculte the distance
19253        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19254 !C now normalize vector
19255       vectube(1)=vectube(1)/tub_r
19256       vectube(2)=vectube(2)/tub_r
19257 !C calculte rdiffrence between r and r0
19258       rdiff=tub_r-tubeR0
19259 !C and its 6 power
19260       rdiff6=rdiff**6.0d0
19261 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19262        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19263 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19264 !C       print *,rdiff,rdiff6,pep_aa_tube
19265 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19266 !C now we calculate gradient
19267        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19268           6.0d0*pep_bb_tube)/rdiff6/rdiff
19269 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19270 !C     &rdiff,fac
19271 !C now direction of gg_tube vector
19272       do j=1,3
19273       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19274       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19275       enddo
19276       enddo
19277 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19278 !C        print *,gg_tube(1,0),"TU"
19279
19280
19281        do i=itube_start,itube_end
19282 !C Lets not jump over memory as we use many times iti
19283        iti=itype(i,1)
19284 !C lets ommit dummy atoms for now
19285        if ((iti.eq.ntyp1)  &
19286 !C in UNRES uncomment the line below as GLY has no side-chain...
19287 !C      .or.(iti.eq.10)
19288       ) cycle
19289       xmin=boxxsize
19290       ymin=boxysize
19291       do j=-1,1
19292        vectube(1)=mod((c(1,i+nres)),boxxsize)
19293        vectube(1)=vectube(1)+boxxsize*j
19294        vectube(2)=mod((c(2,i+nres)),boxysize)
19295        vectube(2)=vectube(2)+boxysize*j
19296
19297        xminact=abs(vectube(1)-tubecenter(1))
19298        yminact=abs(vectube(2)-tubecenter(2))
19299          if (xmin.gt.xminact) then
19300           xmin=xminact
19301           xtemp=vectube(1)
19302          endif
19303          if (ymin.gt.yminact) then
19304            ymin=yminact
19305            ytemp=vectube(2)
19306           endif
19307        enddo
19308       vectube(1)=xtemp
19309       vectube(2)=ytemp
19310 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19311 !C     &     tubecenter(2)
19312       vectube(1)=vectube(1)-tubecenter(1)
19313       vectube(2)=vectube(2)-tubecenter(2)
19314
19315 !C as the tube is infinity we do not calculate the Z-vector use of Z
19316 !C as chosen axis
19317       vectube(3)=0.0d0
19318 !C now calculte the distance
19319        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19320 !C now normalize vector
19321       vectube(1)=vectube(1)/tub_r
19322       vectube(2)=vectube(2)/tub_r
19323
19324 !C calculte rdiffrence between r and r0
19325       rdiff=tub_r-tubeR0
19326 !C and its 6 power
19327       rdiff6=rdiff**6.0d0
19328 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19329        sc_aa_tube=sc_aa_tube_par(iti)
19330        sc_bb_tube=sc_bb_tube_par(iti)
19331        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19332        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19333            6.0d0*sc_bb_tube/rdiff6/rdiff
19334 !C now direction of gg_tube vector
19335        do j=1,3
19336         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19337         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19338        enddo
19339       enddo
19340       do i=itube_start,itube_end
19341         Etube=Etube+enetube(i)+enetube(i+nres)
19342       enddo
19343 !C        print *,"ETUBE", etube
19344       return
19345       end subroutine calctube
19346 !C TO DO 1) add to total energy
19347 !C       2) add to gradient summation
19348 !C       3) add reading parameters (AND of course oppening of PARAM file)
19349 !C       4) add reading the center of tube
19350 !C       5) add COMMONs
19351 !C       6) add to zerograd
19352 !C       7) allocate matrices
19353
19354
19355 !C-----------------------------------------------------------------------
19356 !C-----------------------------------------------------------
19357 !C This subroutine is to mimic the histone like structure but as well can be
19358 !C utilizet to nanostructures (infinit) small modification has to be used to
19359 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19360 !C gradient has to be modified at the ends
19361 !C The energy function is Kihara potential
19362 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19363 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19364 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19365 !C simple Kihara potential
19366       subroutine calctube2(Etube)
19367           real(kind=8),dimension(3) :: vectube
19368       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19369        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19370        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19371       integer:: i,j,iti
19372       Etube=0.0d0
19373       do i=itube_start,itube_end
19374       enetube(i)=0.0d0
19375       enetube(i+nres)=0.0d0
19376       enddo
19377 !C first we calculate the distance from tube center
19378 !C first sugare-phosphate group for NARES this would be peptide group
19379 !C for UNRES
19380        do i=itube_start,itube_end
19381 !C lets ommit dummy atoms for now
19382
19383        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19384 !C now calculate distance from center of tube and direction vectors
19385 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19386 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19387 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19388 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19389       xmin=boxxsize
19390       ymin=boxysize
19391       do j=-1,1
19392        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19393        vectube(1)=vectube(1)+boxxsize*j
19394        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19395        vectube(2)=vectube(2)+boxysize*j
19396
19397        xminact=abs(vectube(1)-tubecenter(1))
19398        yminact=abs(vectube(2)-tubecenter(2))
19399          if (xmin.gt.xminact) then
19400           xmin=xminact
19401           xtemp=vectube(1)
19402          endif
19403          if (ymin.gt.yminact) then
19404            ymin=yminact
19405            ytemp=vectube(2)
19406           endif
19407        enddo
19408       vectube(1)=xtemp
19409       vectube(2)=ytemp
19410       vectube(1)=vectube(1)-tubecenter(1)
19411       vectube(2)=vectube(2)-tubecenter(2)
19412
19413 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19414 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19415
19416 !C as the tube is infinity we do not calculate the Z-vector use of Z
19417 !C as chosen axis
19418       vectube(3)=0.0d0
19419 !C now calculte the distance
19420        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19421 !C now normalize vector
19422       vectube(1)=vectube(1)/tub_r
19423       vectube(2)=vectube(2)/tub_r
19424 !C calculte rdiffrence between r and r0
19425       rdiff=tub_r-tubeR0
19426 !C and its 6 power
19427       rdiff6=rdiff**6.0d0
19428 !C THIS FRAGMENT MAKES TUBE FINITE
19429       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19430       if (positi.le.0) positi=positi+boxzsize
19431 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19432 !c for each residue check if it is in lipid or lipid water border area
19433 !C       respos=mod(c(3,i+nres),boxzsize)
19434 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19435        if ((positi.gt.bordtubebot)  &
19436       .and.(positi.lt.bordtubetop)) then
19437 !C the energy transfer exist
19438       if (positi.lt.buftubebot) then
19439        fracinbuf=1.0d0-  &
19440          ((positi-bordtubebot)/tubebufthick)
19441 !C lipbufthick is thickenes of lipid buffore
19442        sstube=sscalelip(fracinbuf)
19443        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19444 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19445        enetube(i)=enetube(i)+sstube*tubetranenepep
19446 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19447 !C     &+ssgradtube*tubetranene(itype(i,1))
19448 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19449 !C     &+ssgradtube*tubetranene(itype(i,1))
19450 !C         print *,"doing sccale for lower part"
19451       elseif (positi.gt.buftubetop) then
19452        fracinbuf=1.0d0-  &
19453       ((bordtubetop-positi)/tubebufthick)
19454        sstube=sscalelip(fracinbuf)
19455        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19456        enetube(i)=enetube(i)+sstube*tubetranenepep
19457 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19458 !C     &+ssgradtube*tubetranene(itype(i,1))
19459 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19460 !C     &+ssgradtube*tubetranene(itype(i,1))
19461 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19462       else
19463        sstube=1.0d0
19464        ssgradtube=0.0d0
19465        enetube(i)=enetube(i)+sstube*tubetranenepep
19466 !C         print *,"I am in true lipid"
19467       endif
19468       else
19469 !C          sstube=0.0d0
19470 !C          ssgradtube=0.0d0
19471       cycle
19472       endif ! if in lipid or buffor
19473
19474 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19475        enetube(i)=enetube(i)+sstube* &
19476       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19477 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19478 !C       print *,rdiff,rdiff6,pep_aa_tube
19479 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19480 !C now we calculate gradient
19481        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19482            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19483 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19484 !C     &rdiff,fac
19485
19486 !C now direction of gg_tube vector
19487        do j=1,3
19488       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19489       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19490       enddo
19491        gg_tube(3,i)=gg_tube(3,i)  &
19492        +ssgradtube*enetube(i)/sstube/2.0d0
19493        gg_tube(3,i-1)= gg_tube(3,i-1)  &
19494        +ssgradtube*enetube(i)/sstube/2.0d0
19495
19496       enddo
19497 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19498 !C        print *,gg_tube(1,0),"TU"
19499       do i=itube_start,itube_end
19500 !C Lets not jump over memory as we use many times iti
19501        iti=itype(i,1)
19502 !C lets ommit dummy atoms for now
19503        if ((iti.eq.ntyp1) &
19504 !!C in UNRES uncomment the line below as GLY has no side-chain...
19505          .or.(iti.eq.10) &
19506         ) cycle
19507         vectube(1)=c(1,i+nres)
19508         vectube(1)=mod(vectube(1),boxxsize)
19509         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19510         vectube(2)=c(2,i+nres)
19511         vectube(2)=mod(vectube(2),boxysize)
19512         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19513
19514       vectube(1)=vectube(1)-tubecenter(1)
19515       vectube(2)=vectube(2)-tubecenter(2)
19516 !C THIS FRAGMENT MAKES TUBE FINITE
19517       positi=(mod(c(3,i+nres),boxzsize))
19518       if (positi.le.0) positi=positi+boxzsize
19519 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19520 !c for each residue check if it is in lipid or lipid water border area
19521 !C       respos=mod(c(3,i+nres),boxzsize)
19522 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19523
19524        if ((positi.gt.bordtubebot)  &
19525       .and.(positi.lt.bordtubetop)) then
19526 !C the energy transfer exist
19527       if (positi.lt.buftubebot) then
19528        fracinbuf=1.0d0- &
19529           ((positi-bordtubebot)/tubebufthick)
19530 !C lipbufthick is thickenes of lipid buffore
19531        sstube=sscalelip(fracinbuf)
19532        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19533 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19534        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19535 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19536 !C     &+ssgradtube*tubetranene(itype(i,1))
19537 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19538 !C     &+ssgradtube*tubetranene(itype(i,1))
19539 !C         print *,"doing sccale for lower part"
19540       elseif (positi.gt.buftubetop) then
19541        fracinbuf=1.0d0- &
19542       ((bordtubetop-positi)/tubebufthick)
19543
19544        sstube=sscalelip(fracinbuf)
19545        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19546        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19547 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19548 !C     &+ssgradtube*tubetranene(itype(i,1))
19549 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19550 !C     &+ssgradtube*tubetranene(itype(i,1))
19551 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19552       else
19553        sstube=1.0d0
19554        ssgradtube=0.0d0
19555        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19556 !C         print *,"I am in true lipid"
19557       endif
19558       else
19559 !C          sstube=0.0d0
19560 !C          ssgradtube=0.0d0
19561       cycle
19562       endif ! if in lipid or buffor
19563 !CEND OF FINITE FRAGMENT
19564 !C as the tube is infinity we do not calculate the Z-vector use of Z
19565 !C as chosen axis
19566       vectube(3)=0.0d0
19567 !C now calculte the distance
19568        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19569 !C now normalize vector
19570       vectube(1)=vectube(1)/tub_r
19571       vectube(2)=vectube(2)/tub_r
19572 !C calculte rdiffrence between r and r0
19573       rdiff=tub_r-tubeR0
19574 !C and its 6 power
19575       rdiff6=rdiff**6.0d0
19576 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19577        sc_aa_tube=sc_aa_tube_par(iti)
19578        sc_bb_tube=sc_bb_tube_par(iti)
19579        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19580                    *sstube+enetube(i+nres)
19581 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19582 !C now we calculate gradient
19583        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19584           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19585 !C now direction of gg_tube vector
19586        do j=1,3
19587         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19588         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19589        enddo
19590        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19591        +ssgradtube*enetube(i+nres)/sstube
19592        gg_tube(3,i-1)= gg_tube(3,i-1) &
19593        +ssgradtube*enetube(i+nres)/sstube
19594
19595       enddo
19596       do i=itube_start,itube_end
19597         Etube=Etube+enetube(i)+enetube(i+nres)
19598       enddo
19599 !C        print *,"ETUBE", etube
19600       return
19601       end subroutine calctube2
19602 !=====================================================================================================================================
19603       subroutine calcnano(Etube)
19604       real(kind=8),dimension(3) :: vectube
19605
19606       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19607        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19608        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19609        integer:: i,j,iti,r
19610
19611       Etube=0.0d0
19612 !      print *,itube_start,itube_end,"poczatek"
19613       do i=itube_start,itube_end
19614       enetube(i)=0.0d0
19615       enetube(i+nres)=0.0d0
19616       enddo
19617 !C first we calculate the distance from tube center
19618 !C first sugare-phosphate group for NARES this would be peptide group
19619 !C for UNRES
19620        do i=itube_start,itube_end
19621 !C lets ommit dummy atoms for now
19622        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19623 !C now calculate distance from center of tube and direction vectors
19624       xmin=boxxsize
19625       ymin=boxysize
19626       zmin=boxzsize
19627
19628       do j=-1,1
19629        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19630        vectube(1)=vectube(1)+boxxsize*j
19631        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19632        vectube(2)=vectube(2)+boxysize*j
19633        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19634        vectube(3)=vectube(3)+boxzsize*j
19635
19636
19637        xminact=dabs(vectube(1)-tubecenter(1))
19638        yminact=dabs(vectube(2)-tubecenter(2))
19639        zminact=dabs(vectube(3)-tubecenter(3))
19640
19641          if (xmin.gt.xminact) then
19642           xmin=xminact
19643           xtemp=vectube(1)
19644          endif
19645          if (ymin.gt.yminact) then
19646            ymin=yminact
19647            ytemp=vectube(2)
19648           endif
19649          if (zmin.gt.zminact) then
19650            zmin=zminact
19651            ztemp=vectube(3)
19652           endif
19653        enddo
19654       vectube(1)=xtemp
19655       vectube(2)=ytemp
19656       vectube(3)=ztemp
19657
19658       vectube(1)=vectube(1)-tubecenter(1)
19659       vectube(2)=vectube(2)-tubecenter(2)
19660       vectube(3)=vectube(3)-tubecenter(3)
19661
19662 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19663 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19664 !C as the tube is infinity we do not calculate the Z-vector use of Z
19665 !C as chosen axis
19666 !C      vectube(3)=0.0d0
19667 !C now calculte the distance
19668        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19669 !C now normalize vector
19670       vectube(1)=vectube(1)/tub_r
19671       vectube(2)=vectube(2)/tub_r
19672       vectube(3)=vectube(3)/tub_r
19673 !C calculte rdiffrence between r and r0
19674       rdiff=tub_r-tubeR0
19675 !C and its 6 power
19676       rdiff6=rdiff**6.0d0
19677 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19678        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19679 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19680 !C       print *,rdiff,rdiff6,pep_aa_tube
19681 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19682 !C now we calculate gradient
19683        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19684           6.0d0*pep_bb_tube)/rdiff6/rdiff
19685 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19686 !C     &rdiff,fac
19687        if (acavtubpep.eq.0.0d0) then
19688 !C go to 667
19689        enecavtube(i)=0.0
19690        faccav=0.0
19691        else
19692        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19693        enecavtube(i)=  &
19694       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19695       /denominator
19696        enecavtube(i)=0.0
19697        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19698       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19699       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19700       /denominator**2.0d0
19701 !C         faccav=0.0
19702 !C         fac=fac+faccav
19703 !C 667     continue
19704        endif
19705         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19706       do j=1,3
19707       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19708       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19709       enddo
19710       enddo
19711
19712        do i=itube_start,itube_end
19713       enecavtube(i)=0.0d0
19714 !C Lets not jump over memory as we use many times iti
19715        iti=itype(i,1)
19716 !C lets ommit dummy atoms for now
19717        if ((iti.eq.ntyp1) &
19718 !C in UNRES uncomment the line below as GLY has no side-chain...
19719 !C      .or.(iti.eq.10)
19720        ) cycle
19721       xmin=boxxsize
19722       ymin=boxysize
19723       zmin=boxzsize
19724       do j=-1,1
19725        vectube(1)=dmod((c(1,i+nres)),boxxsize)
19726        vectube(1)=vectube(1)+boxxsize*j
19727        vectube(2)=dmod((c(2,i+nres)),boxysize)
19728        vectube(2)=vectube(2)+boxysize*j
19729        vectube(3)=dmod((c(3,i+nres)),boxzsize)
19730        vectube(3)=vectube(3)+boxzsize*j
19731
19732
19733        xminact=dabs(vectube(1)-tubecenter(1))
19734        yminact=dabs(vectube(2)-tubecenter(2))
19735        zminact=dabs(vectube(3)-tubecenter(3))
19736
19737          if (xmin.gt.xminact) then
19738           xmin=xminact
19739           xtemp=vectube(1)
19740          endif
19741          if (ymin.gt.yminact) then
19742            ymin=yminact
19743            ytemp=vectube(2)
19744           endif
19745          if (zmin.gt.zminact) then
19746            zmin=zminact
19747            ztemp=vectube(3)
19748           endif
19749        enddo
19750       vectube(1)=xtemp
19751       vectube(2)=ytemp
19752       vectube(3)=ztemp
19753
19754 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19755 !C     &     tubecenter(2)
19756       vectube(1)=vectube(1)-tubecenter(1)
19757       vectube(2)=vectube(2)-tubecenter(2)
19758       vectube(3)=vectube(3)-tubecenter(3)
19759 !C now calculte the distance
19760        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19761 !C now normalize vector
19762       vectube(1)=vectube(1)/tub_r
19763       vectube(2)=vectube(2)/tub_r
19764       vectube(3)=vectube(3)/tub_r
19765
19766 !C calculte rdiffrence between r and r0
19767       rdiff=tub_r-tubeR0
19768 !C and its 6 power
19769       rdiff6=rdiff**6.0d0
19770        sc_aa_tube=sc_aa_tube_par(iti)
19771        sc_bb_tube=sc_bb_tube_par(iti)
19772        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19773 !C       enetube(i+nres)=0.0d0
19774 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19775 !C now we calculate gradient
19776        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19777           6.0d0*sc_bb_tube/rdiff6/rdiff
19778 !C       fac=0.0
19779 !C now direction of gg_tube vector
19780 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19781        if (acavtub(iti).eq.0.0d0) then
19782 !C go to 667
19783        enecavtube(i+nres)=0.0d0
19784        faccav=0.0d0
19785        else
19786        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19787        enecavtube(i+nres)=   &
19788       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19789       /denominator
19790 !C         enecavtube(i)=0.0
19791        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19792       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19793       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19794       /denominator**2.0d0
19795 !C         faccav=0.0
19796        fac=fac+faccav
19797 !C 667     continue
19798        endif
19799 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19800 !C     &   enecavtube(i),faccav
19801 !C         print *,"licz=",
19802 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19803 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19804        do j=1,3
19805         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19806         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19807        enddo
19808         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19809       enddo
19810
19811
19812
19813       do i=itube_start,itube_end
19814         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19815        +enecavtube(i+nres)
19816       enddo
19817 !        do i=1,20
19818 !         print *,"begin", i,"a"
19819 !         do r=1,10000
19820 !          rdiff=r/100.0d0
19821 !          rdiff6=rdiff**6.0d0
19822 !          sc_aa_tube=sc_aa_tube_par(i)
19823 !          sc_bb_tube=sc_bb_tube_par(i)
19824 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19825 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19826 !          enecavtube(i)=   &
19827 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19828 !         /denominator
19829
19830 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19831 !         enddo
19832 !         print *,"end",i,"a"
19833 !        enddo
19834 !C        print *,"ETUBE", etube
19835       return
19836       end subroutine calcnano
19837
19838 !===============================================
19839 !--------------------------------------------------------------------------------
19840 !C first for shielding is setting of function of side-chains
19841
19842        subroutine set_shield_fac2
19843        real(kind=8) :: div77_81=0.974996043d0, &
19844       div4_81=0.2222222222d0
19845        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19846        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19847        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19848        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19849 !C the vector between center of side_chain and peptide group
19850        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19851        pept_group,costhet_grad,cosphi_grad_long, &
19852        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19853        sh_frac_dist_grad,pep_side
19854       integer i,j,k
19855 !C      write(2,*) "ivec",ivec_start,ivec_end
19856       do i=1,nres
19857       fac_shield(i)=0.0d0
19858       ishield_list(i)=0
19859       do j=1,3
19860       grad_shield(j,i)=0.0d0
19861       enddo
19862       enddo
19863       do i=ivec_start,ivec_end
19864 !C      do i=1,nres-1
19865 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19866 !      ishield_list(i)=0
19867       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19868 !Cif there two consequtive dummy atoms there is no peptide group between them
19869 !C the line below has to be changed for FGPROC>1
19870       VolumeTotal=0.0
19871       do k=1,nres
19872        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19873        dist_pep_side=0.0
19874        dist_side_calf=0.0
19875        do j=1,3
19876 !C first lets set vector conecting the ithe side-chain with kth side-chain
19877       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19878 !C      pep_side(j)=2.0d0
19879 !C and vector conecting the side-chain with its proper calfa
19880       side_calf(j)=c(j,k+nres)-c(j,k)
19881 !C      side_calf(j)=2.0d0
19882       pept_group(j)=c(j,i)-c(j,i+1)
19883 !C lets have their lenght
19884       dist_pep_side=pep_side(j)**2+dist_pep_side
19885       dist_side_calf=dist_side_calf+side_calf(j)**2
19886       dist_pept_group=dist_pept_group+pept_group(j)**2
19887       enddo
19888        dist_pep_side=sqrt(dist_pep_side)
19889        dist_pept_group=sqrt(dist_pept_group)
19890        dist_side_calf=sqrt(dist_side_calf)
19891       do j=1,3
19892       pep_side_norm(j)=pep_side(j)/dist_pep_side
19893       side_calf_norm(j)=dist_side_calf
19894       enddo
19895 !C now sscale fraction
19896        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19897 !       print *,buff_shield,"buff",sh_frac_dist
19898 !C now sscale
19899       if (sh_frac_dist.le.0.0) cycle
19900 !C        print *,ishield_list(i),i
19901 !C If we reach here it means that this side chain reaches the shielding sphere
19902 !C Lets add him to the list for gradient
19903       ishield_list(i)=ishield_list(i)+1
19904 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19905 !C this list is essential otherwise problem would be O3
19906       shield_list(ishield_list(i),i)=k
19907 !C Lets have the sscale value
19908       if (sh_frac_dist.gt.1.0) then
19909        scale_fac_dist=1.0d0
19910        do j=1,3
19911        sh_frac_dist_grad(j)=0.0d0
19912        enddo
19913       else
19914        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19915                   *(2.0d0*sh_frac_dist-3.0d0)
19916        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19917                    /dist_pep_side/buff_shield*0.5d0
19918        do j=1,3
19919        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19920 !C         sh_frac_dist_grad(j)=0.0d0
19921 !C         scale_fac_dist=1.0d0
19922 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19923 !C     &                    sh_frac_dist_grad(j)
19924        enddo
19925       endif
19926 !C this is what is now we have the distance scaling now volume...
19927       short=short_r_sidechain(itype(k,1))
19928       long=long_r_sidechain(itype(k,1))
19929       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19930       sinthet=short/dist_pep_side*costhet
19931 !      print *,"SORT",short,long,sinthet,costhet
19932 !C now costhet_grad
19933 !C       costhet=0.6d0
19934 !C       sinthet=0.8
19935        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19936 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19937 !C     &             -short/dist_pep_side**2/costhet)
19938 !C       costhet_fac=0.0d0
19939        do j=1,3
19940        costhet_grad(j)=costhet_fac*pep_side(j)
19941        enddo
19942 !C remember for the final gradient multiply costhet_grad(j)
19943 !C for side_chain by factor -2 !
19944 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19945 !C pep_side0pept_group is vector multiplication
19946       pep_side0pept_group=0.0d0
19947       do j=1,3
19948       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19949       enddo
19950       cosalfa=(pep_side0pept_group/ &
19951       (dist_pep_side*dist_side_calf))
19952       fac_alfa_sin=1.0d0-cosalfa**2
19953       fac_alfa_sin=dsqrt(fac_alfa_sin)
19954       rkprim=fac_alfa_sin*(long-short)+short
19955 !C      rkprim=short
19956
19957 !C now costhet_grad
19958        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19959 !C       cosphi=0.6
19960        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19961        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19962          dist_pep_side**2)
19963 !C       sinphi=0.8
19964        do j=1,3
19965        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19966       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19967       *(long-short)/fac_alfa_sin*cosalfa/ &
19968       ((dist_pep_side*dist_side_calf))* &
19969       ((side_calf(j))-cosalfa* &
19970       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19971 !C       cosphi_grad_long(j)=0.0d0
19972       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19973       *(long-short)/fac_alfa_sin*cosalfa &
19974       /((dist_pep_side*dist_side_calf))* &
19975       (pep_side(j)- &
19976       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19977 !C       cosphi_grad_loc(j)=0.0d0
19978        enddo
19979 !C      print *,sinphi,sinthet
19980       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19981                    /VSolvSphere_div
19982 !C     &                    *wshield
19983 !C now the gradient...
19984       do j=1,3
19985       grad_shield(j,i)=grad_shield(j,i) &
19986 !C gradient po skalowaniu
19987                  +(sh_frac_dist_grad(j)*VofOverlap &
19988 !C  gradient po costhet
19989           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19990       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19991           sinphi/sinthet*costhet*costhet_grad(j) &
19992          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19993       )*wshield
19994 !C grad_shield_side is Cbeta sidechain gradient
19995       grad_shield_side(j,ishield_list(i),i)=&
19996            (sh_frac_dist_grad(j)*-2.0d0&
19997            *VofOverlap&
19998           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19999        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20000           sinphi/sinthet*costhet*costhet_grad(j)&
20001          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20002           )*wshield
20003 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20004 !            sinphi/sinthet,&
20005 !           +sinthet/sinphi,"HERE"
20006        grad_shield_loc(j,ishield_list(i),i)=   &
20007           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20008       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20009           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20010            ))&
20011            *wshield
20012 !         print *,grad_shield_loc(j,ishield_list(i),i)
20013       enddo
20014       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20015       enddo
20016       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20017
20018 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20019       enddo
20020       return
20021       end subroutine set_shield_fac2
20022 !----------------------------------------------------------------------------
20023 ! SOUBROUTINE FOR AFM
20024        subroutine AFMvel(Eafmforce)
20025        use MD_data, only:totTafm
20026       real(kind=8),dimension(3) :: diffafm
20027       real(kind=8) :: afmdist,Eafmforce
20028        integer :: i
20029 !C Only for check grad COMMENT if not used for checkgrad
20030 !C      totT=3.0d0
20031 !C--------------------------------------------------------
20032 !C      print *,"wchodze"
20033       afmdist=0.0d0
20034       Eafmforce=0.0d0
20035       do i=1,3
20036       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20037       afmdist=afmdist+diffafm(i)**2
20038       enddo
20039       afmdist=dsqrt(afmdist)
20040 !      totTafm=3.0
20041       Eafmforce=0.5d0*forceAFMconst &
20042       *(distafminit+totTafm*velAFMconst-afmdist)**2
20043 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20044       do i=1,3
20045       gradafm(i,afmend-1)=-forceAFMconst* &
20046        (distafminit+totTafm*velAFMconst-afmdist) &
20047        *diffafm(i)/afmdist
20048       gradafm(i,afmbeg-1)=forceAFMconst* &
20049       (distafminit+totTafm*velAFMconst-afmdist) &
20050       *diffafm(i)/afmdist
20051       enddo
20052 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20053       return
20054       end subroutine AFMvel
20055 !---------------------------------------------------------
20056        subroutine AFMforce(Eafmforce)
20057
20058       real(kind=8),dimension(3) :: diffafm
20059 !      real(kind=8) ::afmdist
20060       real(kind=8) :: afmdist,Eafmforce
20061       integer :: i
20062       afmdist=0.0d0
20063       Eafmforce=0.0d0
20064       do i=1,3
20065       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20066       afmdist=afmdist+diffafm(i)**2
20067       enddo
20068       afmdist=dsqrt(afmdist)
20069 !      print *,afmdist,distafminit
20070       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20071       do i=1,3
20072       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20073       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20074       enddo
20075 !C      print *,'AFM',Eafmforce
20076       return
20077       end subroutine AFMforce
20078
20079 !-----------------------------------------------------------------------------
20080 #ifdef WHAM
20081       subroutine read_ssHist
20082 !      implicit none
20083 !      Includes
20084 !      include 'DIMENSIONS'
20085 !      include "DIMENSIONS.FREE"
20086 !      include 'COMMON.FREE'
20087 !     Local variables
20088       integer :: i,j
20089       character(len=80) :: controlcard
20090
20091       do i=1,dyn_nssHist
20092       call card_concat(controlcard,.true.)
20093       read(controlcard,*) &
20094            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20095       enddo
20096
20097       return
20098       end subroutine read_ssHist
20099 #endif
20100 !-----------------------------------------------------------------------------
20101       integer function indmat(i,j)
20102 !el
20103 ! get the position of the jth ijth fragment of the chain coordinate system
20104 ! in the fromto array.
20105       integer :: i,j
20106
20107       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20108       return
20109       end function indmat
20110 !-----------------------------------------------------------------------------
20111       real(kind=8) function sigm(x)
20112 !el
20113        real(kind=8) :: x
20114       sigm=0.25d0*x
20115       return
20116       end function sigm
20117 !-----------------------------------------------------------------------------
20118 !-----------------------------------------------------------------------------
20119       subroutine alloc_ener_arrays
20120 !EL Allocation of arrays used by module energy
20121       use MD_data, only: mset
20122 !el local variables
20123       integer :: i,j
20124
20125       if(nres.lt.100) then
20126       maxconts=10*nres
20127       elseif(nres.lt.200) then
20128       maxconts=10*nres      ! Max. number of contacts per residue
20129       else
20130       maxconts=10*nres ! (maxconts=maxres/4)
20131       endif
20132       maxcont=12*nres      ! Max. number of SC contacts
20133       maxvar=6*nres      ! Max. number of variables
20134 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20135       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20136 !----------------------
20137 ! arrays in subroutine init_int_table
20138 !el#ifdef MPI
20139 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20140 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20141 !el#endif
20142       allocate(nint_gr(nres))
20143       allocate(nscp_gr(nres))
20144       allocate(ielstart(nres))
20145       allocate(ielend(nres))
20146 !(maxres)
20147       allocate(istart(nres,maxint_gr))
20148       allocate(iend(nres,maxint_gr))
20149 !(maxres,maxint_gr)
20150       allocate(iscpstart(nres,maxint_gr))
20151       allocate(iscpend(nres,maxint_gr))
20152 !(maxres,maxint_gr)
20153       allocate(ielstart_vdw(nres))
20154       allocate(ielend_vdw(nres))
20155 !(maxres)
20156       allocate(nint_gr_nucl(nres))
20157       allocate(nscp_gr_nucl(nres))
20158       allocate(ielstart_nucl(nres))
20159       allocate(ielend_nucl(nres))
20160 !(maxres)
20161       allocate(istart_nucl(nres,maxint_gr))
20162       allocate(iend_nucl(nres,maxint_gr))
20163 !(maxres,maxint_gr)
20164       allocate(iscpstart_nucl(nres,maxint_gr))
20165       allocate(iscpend_nucl(nres,maxint_gr))
20166 !(maxres,maxint_gr)
20167       allocate(ielstart_vdw_nucl(nres))
20168       allocate(ielend_vdw_nucl(nres))
20169
20170       allocate(lentyp(0:nfgtasks-1))
20171 !(0:maxprocs-1)
20172 !----------------------
20173 ! commom.contacts
20174 !      common /contacts/
20175       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20176       allocate(icont(2,maxcont))
20177 !(2,maxcont)
20178 !      common /contacts1/
20179       allocate(num_cont(0:nres+4))
20180 !(maxres)
20181       allocate(jcont(maxconts,nres))
20182 !(maxconts,maxres)
20183       allocate(facont(maxconts,nres))
20184 !(maxconts,maxres)
20185       allocate(gacont(3,maxconts,nres))
20186 !(3,maxconts,maxres)
20187 !      common /contacts_hb/
20188       allocate(gacontp_hb1(3,maxconts,nres))
20189       allocate(gacontp_hb2(3,maxconts,nres))
20190       allocate(gacontp_hb3(3,maxconts,nres))
20191       allocate(gacontm_hb1(3,maxconts,nres))
20192       allocate(gacontm_hb2(3,maxconts,nres))
20193       allocate(gacontm_hb3(3,maxconts,nres))
20194       allocate(gacont_hbr(3,maxconts,nres))
20195       allocate(grij_hb_cont(3,maxconts,nres))
20196 !(3,maxconts,maxres)
20197       allocate(facont_hb(maxconts,nres))
20198
20199       allocate(ees0p(maxconts,nres))
20200       allocate(ees0m(maxconts,nres))
20201       allocate(d_cont(maxconts,nres))
20202       allocate(ees0plist(maxconts,nres))
20203
20204 !(maxconts,maxres)
20205       allocate(num_cont_hb(nres))
20206 !(maxres)
20207       allocate(jcont_hb(maxconts,nres))
20208 !(maxconts,maxres)
20209 !      common /rotat/
20210       allocate(Ug(2,2,nres))
20211       allocate(Ugder(2,2,nres))
20212       allocate(Ug2(2,2,nres))
20213       allocate(Ug2der(2,2,nres))
20214 !(2,2,maxres)
20215       allocate(obrot(2,nres))
20216       allocate(obrot2(2,nres))
20217       allocate(obrot_der(2,nres))
20218       allocate(obrot2_der(2,nres))
20219 !(2,maxres)
20220 !      common /precomp1/
20221       allocate(mu(2,nres))
20222       allocate(muder(2,nres))
20223       allocate(Ub2(2,nres))
20224       Ub2(1,:)=0.0d0
20225       Ub2(2,:)=0.0d0
20226       allocate(Ub2der(2,nres))
20227       allocate(Ctobr(2,nres))
20228       allocate(Ctobrder(2,nres))
20229       allocate(Dtobr2(2,nres))
20230       allocate(Dtobr2der(2,nres))
20231 !(2,maxres)
20232       allocate(EUg(2,2,nres))
20233       allocate(EUgder(2,2,nres))
20234       allocate(CUg(2,2,nres))
20235       allocate(CUgder(2,2,nres))
20236       allocate(DUg(2,2,nres))
20237       allocate(Dugder(2,2,nres))
20238       allocate(DtUg2(2,2,nres))
20239       allocate(DtUg2der(2,2,nres))
20240 !(2,2,maxres)
20241 !      common /precomp2/
20242       allocate(Ug2Db1t(2,nres))
20243       allocate(Ug2Db1tder(2,nres))
20244       allocate(CUgb2(2,nres))
20245       allocate(CUgb2der(2,nres))
20246 !(2,maxres)
20247       allocate(EUgC(2,2,nres))
20248       allocate(EUgCder(2,2,nres))
20249       allocate(EUgD(2,2,nres))
20250       allocate(EUgDder(2,2,nres))
20251       allocate(DtUg2EUg(2,2,nres))
20252       allocate(Ug2DtEUg(2,2,nres))
20253 !(2,2,maxres)
20254       allocate(Ug2DtEUgder(2,2,2,nres))
20255       allocate(DtUg2EUgder(2,2,2,nres))
20256 !(2,2,2,maxres)
20257       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20258       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20259       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20260       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20261
20262       allocate(ctilde(2,2,nres))
20263       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20264       allocate(gtb1(2,nres))
20265       allocate(gtb2(2,nres))
20266       allocate(cc(2,2,nres))
20267       allocate(dd(2,2,nres))
20268       allocate(ee(2,2,nres))
20269       allocate(gtcc(2,2,nres))
20270       allocate(gtdd(2,2,nres))
20271       allocate(gtee(2,2,nres))
20272       allocate(gUb2(2,nres))
20273       allocate(gteUg(2,2,nres))
20274
20275 !      common /rotat_old/
20276       allocate(costab(nres))
20277       allocate(sintab(nres))
20278       allocate(costab2(nres))
20279       allocate(sintab2(nres))
20280 !(maxres)
20281 !      common /dipmat/
20282       allocate(a_chuj(2,2,maxconts,nres))
20283 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20284       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20285 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20286 !      common /contdistrib/
20287       allocate(ncont_sent(nres))
20288       allocate(ncont_recv(nres))
20289
20290       allocate(iat_sent(nres))
20291 !(maxres)
20292       allocate(iint_sent(4,nres,nres))
20293       allocate(iint_sent_local(4,nres,nres))
20294 !(4,maxres,maxres)
20295       allocate(iturn3_sent(4,0:nres+4))
20296       allocate(iturn4_sent(4,0:nres+4))
20297       allocate(iturn3_sent_local(4,nres))
20298       allocate(iturn4_sent_local(4,nres))
20299 !(4,maxres)
20300       allocate(itask_cont_from(0:nfgtasks-1))
20301       allocate(itask_cont_to(0:nfgtasks-1))
20302 !(0:max_fg_procs-1)
20303
20304
20305
20306 !----------------------
20307 ! commom.deriv;
20308 !      common /derivat/
20309       allocate(dcdv(6,maxdim))
20310       allocate(dxdv(6,maxdim))
20311 !(6,maxdim)
20312       allocate(dxds(6,nres))
20313 !(6,maxres)
20314       allocate(gradx(3,-1:nres,0:2))
20315       allocate(gradc(3,-1:nres,0:2))
20316 !(3,maxres,2)
20317       allocate(gvdwx(3,-1:nres))
20318       allocate(gvdwc(3,-1:nres))
20319       allocate(gelc(3,-1:nres))
20320       allocate(gelc_long(3,-1:nres))
20321       allocate(gvdwpp(3,-1:nres))
20322       allocate(gvdwc_scpp(3,-1:nres))
20323       allocate(gradx_scp(3,-1:nres))
20324       allocate(gvdwc_scp(3,-1:nres))
20325       allocate(ghpbx(3,-1:nres))
20326       allocate(ghpbc(3,-1:nres))
20327       allocate(gradcorr(3,-1:nres))
20328       allocate(gradcorr_long(3,-1:nres))
20329       allocate(gradcorr5_long(3,-1:nres))
20330       allocate(gradcorr6_long(3,-1:nres))
20331       allocate(gcorr6_turn_long(3,-1:nres))
20332       allocate(gradxorr(3,-1:nres))
20333       allocate(gradcorr5(3,-1:nres))
20334       allocate(gradcorr6(3,-1:nres))
20335       allocate(gliptran(3,-1:nres))
20336       allocate(gliptranc(3,-1:nres))
20337       allocate(gliptranx(3,-1:nres))
20338       allocate(gshieldx(3,-1:nres))
20339       allocate(gshieldc(3,-1:nres))
20340       allocate(gshieldc_loc(3,-1:nres))
20341       allocate(gshieldx_ec(3,-1:nres))
20342       allocate(gshieldc_ec(3,-1:nres))
20343       allocate(gshieldc_loc_ec(3,-1:nres))
20344       allocate(gshieldx_t3(3,-1:nres))
20345       allocate(gshieldc_t3(3,-1:nres))
20346       allocate(gshieldc_loc_t3(3,-1:nres))
20347       allocate(gshieldx_t4(3,-1:nres))
20348       allocate(gshieldc_t4(3,-1:nres))
20349       allocate(gshieldc_loc_t4(3,-1:nres))
20350       allocate(gshieldx_ll(3,-1:nres))
20351       allocate(gshieldc_ll(3,-1:nres))
20352       allocate(gshieldc_loc_ll(3,-1:nres))
20353       allocate(grad_shield(3,-1:nres))
20354       allocate(gg_tube_sc(3,-1:nres))
20355       allocate(gg_tube(3,-1:nres))
20356       allocate(gradafm(3,-1:nres))
20357       allocate(gradb_nucl(3,-1:nres))
20358       allocate(gradbx_nucl(3,-1:nres))
20359       allocate(gvdwpsb1(3,-1:nres))
20360       allocate(gelpp(3,-1:nres))
20361       allocate(gvdwpsb(3,-1:nres))
20362       allocate(gelsbc(3,-1:nres))
20363       allocate(gelsbx(3,-1:nres))
20364       allocate(gvdwsbx(3,-1:nres))
20365       allocate(gvdwsbc(3,-1:nres))
20366       allocate(gsbloc(3,-1:nres))
20367       allocate(gsblocx(3,-1:nres))
20368       allocate(gradcorr_nucl(3,-1:nres))
20369       allocate(gradxorr_nucl(3,-1:nres))
20370       allocate(gradcorr3_nucl(3,-1:nres))
20371       allocate(gradxorr3_nucl(3,-1:nres))
20372       allocate(gvdwpp_nucl(3,-1:nres))
20373       allocate(gradpepcat(3,-1:nres))
20374       allocate(gradpepcatx(3,-1:nres))
20375       allocate(gradcatcat(3,-1:nres))
20376       allocate(gradnuclcat(3,-1:nres))
20377       allocate(gradnuclcatx(3,-1:nres))
20378 !(3,maxres)
20379       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20380       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20381 ! grad for shielding surroing
20382       allocate(gloc(0:maxvar,0:2))
20383       allocate(gloc_x(0:maxvar,2))
20384 !(maxvar,2)
20385       allocate(gel_loc(3,-1:nres))
20386       allocate(gel_loc_long(3,-1:nres))
20387       allocate(gcorr3_turn(3,-1:nres))
20388       allocate(gcorr4_turn(3,-1:nres))
20389       allocate(gcorr6_turn(3,-1:nres))
20390       allocate(gradb(3,-1:nres))
20391       allocate(gradbx(3,-1:nres))
20392 !(3,maxres)
20393       allocate(gel_loc_loc(maxvar))
20394       allocate(gel_loc_turn3(maxvar))
20395       allocate(gel_loc_turn4(maxvar))
20396       allocate(gel_loc_turn6(maxvar))
20397       allocate(gcorr_loc(maxvar))
20398       allocate(g_corr5_loc(maxvar))
20399       allocate(g_corr6_loc(maxvar))
20400 !(maxvar)
20401       allocate(gsccorc(3,-1:nres))
20402       allocate(gsccorx(3,-1:nres))
20403 !(3,maxres)
20404       allocate(gsccor_loc(-1:nres))
20405 !(maxres)
20406       allocate(gvdwx_scbase(3,-1:nres))
20407       allocate(gvdwc_scbase(3,-1:nres))
20408       allocate(gvdwx_pepbase(3,-1:nres))
20409       allocate(gvdwc_pepbase(3,-1:nres))
20410       allocate(gvdwx_scpho(3,-1:nres))
20411       allocate(gvdwc_scpho(3,-1:nres))
20412       allocate(gvdwc_peppho(3,-1:nres))
20413
20414       allocate(dtheta(3,2,-1:nres))
20415 !(3,2,maxres)
20416       allocate(gscloc(3,-1:nres))
20417       allocate(gsclocx(3,-1:nres))
20418 !(3,maxres)
20419       allocate(dphi(3,3,-1:nres))
20420       allocate(dalpha(3,3,-1:nres))
20421       allocate(domega(3,3,-1:nres))
20422 !(3,3,maxres)
20423 !      common /deriv_scloc/
20424       allocate(dXX_C1tab(3,nres))
20425       allocate(dYY_C1tab(3,nres))
20426       allocate(dZZ_C1tab(3,nres))
20427       allocate(dXX_Ctab(3,nres))
20428       allocate(dYY_Ctab(3,nres))
20429       allocate(dZZ_Ctab(3,nres))
20430       allocate(dXX_XYZtab(3,nres))
20431       allocate(dYY_XYZtab(3,nres))
20432       allocate(dZZ_XYZtab(3,nres))
20433 !(3,maxres)
20434 !      common /mpgrad/
20435       allocate(jgrad_start(nres))
20436       allocate(jgrad_end(nres))
20437 !(maxres)
20438 !----------------------
20439
20440 !      common /indices/
20441       allocate(ibond_displ(0:nfgtasks-1))
20442       allocate(ibond_count(0:nfgtasks-1))
20443       allocate(ithet_displ(0:nfgtasks-1))
20444       allocate(ithet_count(0:nfgtasks-1))
20445       allocate(iphi_displ(0:nfgtasks-1))
20446       allocate(iphi_count(0:nfgtasks-1))
20447       allocate(iphi1_displ(0:nfgtasks-1))
20448       allocate(iphi1_count(0:nfgtasks-1))
20449       allocate(ivec_displ(0:nfgtasks-1))
20450       allocate(ivec_count(0:nfgtasks-1))
20451       allocate(iset_displ(0:nfgtasks-1))
20452       allocate(iset_count(0:nfgtasks-1))
20453       allocate(iint_count(0:nfgtasks-1))
20454       allocate(iint_displ(0:nfgtasks-1))
20455 !(0:max_fg_procs-1)
20456 !----------------------
20457 ! common.MD
20458 !      common /mdgrad/
20459       allocate(gcart(3,-1:nres))
20460       allocate(gxcart(3,-1:nres))
20461 !(3,0:MAXRES)
20462       allocate(gradcag(3,-1:nres))
20463       allocate(gradxag(3,-1:nres))
20464 !(3,MAXRES)
20465 !      common /back_constr/
20466 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20467       allocate(dutheta(nres))
20468       allocate(dugamma(nres))
20469 !(maxres)
20470       allocate(duscdiff(3,nres))
20471       allocate(duscdiffx(3,nres))
20472 !(3,maxres)
20473 !el i io:read_fragments
20474 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20475 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20476 !      common /qmeas/
20477 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20478 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20479       allocate(mset(0:nprocs))  !(maxprocs/20)
20480       mset(:)=0
20481 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20482 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20483       allocate(dUdconst(3,0:nres))
20484       allocate(dUdxconst(3,0:nres))
20485       allocate(dqwol(3,0:nres))
20486       allocate(dxqwol(3,0:nres))
20487 !(3,0:MAXRES)
20488 !----------------------
20489 ! common.sbridge
20490 !      common /sbridge/ in io_common: read_bridge
20491 !el    allocate((:),allocatable :: iss      !(maxss)
20492 !      common /links/  in io_common: read_bridge
20493 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20494 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20495 !      common /dyn_ssbond/
20496 ! and side-chain vectors in theta or phi.
20497       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20498 !(maxres,maxres)
20499 !      do i=1,nres
20500 !        do j=i+1,nres
20501       dyn_ssbond_ij(:,:)=1.0d300
20502 !        enddo
20503 !      enddo
20504
20505 !      if (nss.gt.0) then
20506       allocate(idssb(maxdim),jdssb(maxdim))
20507 !        allocate(newihpb(nss),newjhpb(nss))
20508 !(maxdim)
20509 !      endif
20510       allocate(ishield_list(-1:nres))
20511       allocate(shield_list(maxcontsshi,-1:nres))
20512       allocate(dyn_ss_mask(nres))
20513       allocate(fac_shield(-1:nres))
20514       allocate(enetube(nres*2))
20515       allocate(enecavtube(nres*2))
20516
20517 !(maxres)
20518       dyn_ss_mask(:)=.false.
20519 !----------------------
20520 ! common.sccor
20521 ! Parameters of the SCCOR term
20522 !      common/sccor/
20523 !el in io_conf: parmread
20524 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20525 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20526 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20527 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20528 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20529 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20530 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20531 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20532 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20533 !----------------
20534       allocate(gloc_sc(3,0:2*nres,0:10))
20535 !(3,0:maxres2,10)maxres2=2*maxres
20536       allocate(dcostau(3,3,3,2*nres))
20537       allocate(dsintau(3,3,3,2*nres))
20538       allocate(dtauangle(3,3,3,2*nres))
20539       allocate(dcosomicron(3,3,3,2*nres))
20540       allocate(domicron(3,3,3,2*nres))
20541 !(3,3,3,maxres2)maxres2=2*maxres
20542 !----------------------
20543 ! common.var
20544 !      common /restr/
20545       allocate(varall(maxvar))
20546 !(maxvar)(maxvar=6*maxres)
20547       allocate(mask_theta(nres))
20548       allocate(mask_phi(nres))
20549       allocate(mask_side(nres))
20550 !(maxres)
20551 !----------------------
20552 ! common.vectors
20553 !      common /vectors/
20554       allocate(uy(3,nres))
20555       allocate(uz(3,nres))
20556 !(3,maxres)
20557       allocate(uygrad(3,3,2,nres))
20558       allocate(uzgrad(3,3,2,nres))
20559 !(3,3,2,maxres)
20560 ! allocateion of lists JPRDLA
20561       allocate(newcontlistppi(300*nres))
20562       allocate(newcontlistscpi(350*nres))
20563       allocate(newcontlisti(300*nres))
20564       allocate(newcontlistppj(300*nres))
20565       allocate(newcontlistscpj(350*nres))
20566       allocate(newcontlistj(300*nres))
20567
20568       return
20569       end subroutine alloc_ener_arrays
20570 !-----------------------------------------------------------------
20571       subroutine ebond_nucl(estr_nucl)
20572 !c
20573 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20574 !c
20575
20576       real(kind=8),dimension(3) :: u,ud
20577       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20578       real(kind=8) :: estr_nucl,diff
20579       integer :: iti,i,j,k,nbi
20580       estr_nucl=0.0d0
20581 !C      print *,"I enter ebond"
20582       if (energy_dec) &
20583       write (iout,*) "ibondp_start,ibondp_end",&
20584        ibondp_nucl_start,ibondp_nucl_end
20585       do i=ibondp_nucl_start,ibondp_nucl_end
20586       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20587        itype(i,2).eq.ntyp1_molec(2)) cycle
20588 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20589 !          do j=1,3
20590 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20591 !     &      *dc(j,i-1)/vbld(i)
20592 !          enddo
20593 !          if (energy_dec) write(iout,*)
20594 !     &       "estr1",i,vbld(i),distchainmax,
20595 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20596
20597         diff = vbld(i)-vbldp0_nucl
20598         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20599         vbldp0_nucl,diff,AKP_nucl*diff*diff
20600         estr_nucl=estr_nucl+diff*diff
20601 !          print *,estr_nucl
20602         do j=1,3
20603           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20604         enddo
20605 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20606       enddo
20607       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20608 !      print *,"partial sum", estr_nucl,AKP_nucl
20609
20610       if (energy_dec) &
20611       write (iout,*) "ibondp_start,ibondp_end",&
20612        ibond_nucl_start,ibond_nucl_end
20613
20614       do i=ibond_nucl_start,ibond_nucl_end
20615 !C        print *, "I am stuck",i
20616       iti=itype(i,2)
20617       if (iti.eq.ntyp1_molec(2)) cycle
20618         nbi=nbondterm_nucl(iti)
20619 !C        print *,iti,nbi
20620         if (nbi.eq.1) then
20621           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20622
20623           if (energy_dec) &
20624          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20625          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20626           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20627 !            print *,estr_nucl
20628           do j=1,3
20629             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20630           enddo
20631         else
20632           do j=1,nbi
20633             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20634             ud(j)=aksc_nucl(j,iti)*diff
20635             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20636           enddo
20637           uprod=u(1)
20638           do j=2,nbi
20639             uprod=uprod*u(j)
20640           enddo
20641           usum=0.0d0
20642           usumsqder=0.0d0
20643           do j=1,nbi
20644             uprod1=1.0d0
20645             uprod2=1.0d0
20646             do k=1,nbi
20647             if (k.ne.j) then
20648               uprod1=uprod1*u(k)
20649               uprod2=uprod2*u(k)*u(k)
20650             endif
20651             enddo
20652             usum=usum+uprod1
20653             usumsqder=usumsqder+ud(j)*uprod2
20654           enddo
20655           estr_nucl=estr_nucl+uprod/usum
20656           do j=1,3
20657            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20658           enddo
20659       endif
20660       enddo
20661 !C      print *,"I am about to leave ebond"
20662       return
20663       end subroutine ebond_nucl
20664
20665 !-----------------------------------------------------------------------------
20666       subroutine ebend_nucl(etheta_nucl)
20667       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20668       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20669       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20670       logical :: lprn=.false., lprn1=.false.
20671 !el local variables
20672       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20673       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20674       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20675 ! local variables for constrains
20676       real(kind=8) :: difi,thetiii
20677        integer itheta
20678       etheta_nucl=0.0D0
20679 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20680       do i=ithet_nucl_start,ithet_nucl_end
20681       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20682       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20683       (itype(i,2).eq.ntyp1_molec(2))) cycle
20684       dethetai=0.0d0
20685       dephii=0.0d0
20686       dephii1=0.0d0
20687       theti2=0.5d0*theta(i)
20688       ityp2=ithetyp_nucl(itype(i-1,2))
20689       do k=1,nntheterm_nucl
20690         coskt(k)=dcos(k*theti2)
20691         sinkt(k)=dsin(k*theti2)
20692       enddo
20693       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20694 #ifdef OSF
20695         phii=phi(i)
20696         if (phii.ne.phii) phii=150.0
20697 #else
20698         phii=phi(i)
20699 #endif
20700         ityp1=ithetyp_nucl(itype(i-2,2))
20701         do k=1,nsingle_nucl
20702           cosph1(k)=dcos(k*phii)
20703           sinph1(k)=dsin(k*phii)
20704         enddo
20705       else
20706         phii=0.0d0
20707         ityp1=nthetyp_nucl+1
20708         do k=1,nsingle_nucl
20709           cosph1(k)=0.0d0
20710           sinph1(k)=0.0d0
20711         enddo
20712       endif
20713
20714       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20715 #ifdef OSF
20716         phii1=phi(i+1)
20717         if (phii1.ne.phii1) phii1=150.0
20718         phii1=pinorm(phii1)
20719 #else
20720         phii1=phi(i+1)
20721 #endif
20722         ityp3=ithetyp_nucl(itype(i,2))
20723         do k=1,nsingle_nucl
20724           cosph2(k)=dcos(k*phii1)
20725           sinph2(k)=dsin(k*phii1)
20726         enddo
20727       else
20728         phii1=0.0d0
20729         ityp3=nthetyp_nucl+1
20730         do k=1,nsingle_nucl
20731           cosph2(k)=0.0d0
20732           sinph2(k)=0.0d0
20733         enddo
20734       endif
20735       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20736       do k=1,ndouble_nucl
20737         do l=1,k-1
20738           ccl=cosph1(l)*cosph2(k-l)
20739           ssl=sinph1(l)*sinph2(k-l)
20740           scl=sinph1(l)*cosph2(k-l)
20741           csl=cosph1(l)*sinph2(k-l)
20742           cosph1ph2(l,k)=ccl-ssl
20743           cosph1ph2(k,l)=ccl+ssl
20744           sinph1ph2(l,k)=scl+csl
20745           sinph1ph2(k,l)=scl-csl
20746         enddo
20747       enddo
20748       if (lprn) then
20749       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20750        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20751       write (iout,*) "coskt and sinkt",nntheterm_nucl
20752       do k=1,nntheterm_nucl
20753         write (iout,*) k,coskt(k),sinkt(k)
20754       enddo
20755       endif
20756       do k=1,ntheterm_nucl
20757         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20758         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20759          *coskt(k)
20760         if (lprn)&
20761        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20762         " ethetai",ethetai
20763       enddo
20764       if (lprn) then
20765       write (iout,*) "cosph and sinph"
20766       do k=1,nsingle_nucl
20767         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20768       enddo
20769       write (iout,*) "cosph1ph2 and sinph2ph2"
20770       do k=2,ndouble_nucl
20771         do l=1,k-1
20772           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20773             sinph1ph2(l,k),sinph1ph2(k,l)
20774         enddo
20775       enddo
20776       write(iout,*) "ethetai",ethetai
20777       endif
20778       do m=1,ntheterm2_nucl
20779         do k=1,nsingle_nucl
20780           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20781             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20782             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20783             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20784           ethetai=ethetai+sinkt(m)*aux
20785           dethetai=dethetai+0.5d0*m*aux*coskt(m)
20786           dephii=dephii+k*sinkt(m)*(&
20787              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20788              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20789           dephii1=dephii1+k*sinkt(m)*(&
20790              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20791              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20792           if (lprn) &
20793          write (iout,*) "m",m," k",k," bbthet",&
20794             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20795             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20796             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20797             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20798         enddo
20799       enddo
20800       if (lprn) &
20801       write(iout,*) "ethetai",ethetai
20802       do m=1,ntheterm3_nucl
20803         do k=2,ndouble_nucl
20804           do l=1,k-1
20805             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20806              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20807              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20808              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20809             ethetai=ethetai+sinkt(m)*aux
20810             dethetai=dethetai+0.5d0*m*coskt(m)*aux
20811             dephii=dephii+l*sinkt(m)*(&
20812             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20813              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20814              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20815              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20816             dephii1=dephii1+(k-l)*sinkt(m)*( &
20817             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20818              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20819              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20820              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20821             if (lprn) then
20822             write (iout,*) "m",m," k",k," l",l," ffthet", &
20823              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20824              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20825              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20826              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20827             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20828              cosph1ph2(k,l)*sinkt(m),&
20829              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20830             endif
20831           enddo
20832         enddo
20833       enddo
20834 10      continue
20835       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20836       i,theta(i)*rad2deg,phii*rad2deg, &
20837       phii1*rad2deg,ethetai
20838       etheta_nucl=etheta_nucl+ethetai
20839 !        print *,i,"partial sum",etheta_nucl
20840       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20841       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20842       gloc(nphi+i-2,icg)=wang_nucl*dethetai
20843       enddo
20844       return
20845       end subroutine ebend_nucl
20846 !----------------------------------------------------
20847       subroutine etor_nucl(etors_nucl)
20848 !      implicit real*8 (a-h,o-z)
20849 !      include 'DIMENSIONS'
20850 !      include 'COMMON.VAR'
20851 !      include 'COMMON.GEO'
20852 !      include 'COMMON.LOCAL'
20853 !      include 'COMMON.TORSION'
20854 !      include 'COMMON.INTERACT'
20855 !      include 'COMMON.DERIV'
20856 !      include 'COMMON.CHAIN'
20857 !      include 'COMMON.NAMES'
20858 !      include 'COMMON.IOUNITS'
20859 !      include 'COMMON.FFIELD'
20860 !      include 'COMMON.TORCNSTR'
20861 !      include 'COMMON.CONTROL'
20862       real(kind=8) :: etors_nucl,edihcnstr
20863       logical :: lprn
20864 !el local variables
20865       integer :: i,j,iblock,itori,itori1
20866       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20867                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20868 ! Set lprn=.true. for debugging
20869       lprn=.false.
20870 !     lprn=.true.
20871       etors_nucl=0.0D0
20872 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20873       do i=iphi_nucl_start,iphi_nucl_end
20874       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20875            .or. itype(i-3,2).eq.ntyp1_molec(2) &
20876            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20877       etors_ii=0.0D0
20878       itori=itortyp_nucl(itype(i-2,2))
20879       itori1=itortyp_nucl(itype(i-1,2))
20880       phii=phi(i)
20881 !         print *,i,itori,itori1
20882       gloci=0.0D0
20883 !C Regular cosine and sine terms
20884       do j=1,nterm_nucl(itori,itori1)
20885         v1ij=v1_nucl(j,itori,itori1)
20886         v2ij=v2_nucl(j,itori,itori1)
20887         cosphi=dcos(j*phii)
20888         sinphi=dsin(j*phii)
20889         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20890         if (energy_dec) etors_ii=etors_ii+&
20891                  v1ij*cosphi+v2ij*sinphi
20892         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20893       enddo
20894 !C Lorentz terms
20895 !C                         v1
20896 !C  E = SUM ----------------------------------- - v1
20897 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20898 !C
20899       cosphi=dcos(0.5d0*phii)
20900       sinphi=dsin(0.5d0*phii)
20901       do j=1,nlor_nucl(itori,itori1)
20902         vl1ij=vlor1_nucl(j,itori,itori1)
20903         vl2ij=vlor2_nucl(j,itori,itori1)
20904         vl3ij=vlor3_nucl(j,itori,itori1)
20905         pom=vl2ij*cosphi+vl3ij*sinphi
20906         pom1=1.0d0/(pom*pom+1.0d0)
20907         etors_nucl=etors_nucl+vl1ij*pom1
20908         if (energy_dec) etors_ii=etors_ii+ &
20909                  vl1ij*pom1
20910         pom=-pom*pom1*pom1
20911         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20912       enddo
20913 !C Subtract the constant term
20914       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20915         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20916             'etor',i,etors_ii-v0_nucl(itori,itori1)
20917       if (lprn) &
20918        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20919        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20920        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20921       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20922 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20923       enddo
20924       return
20925       end subroutine etor_nucl
20926 !------------------------------------------------------------
20927       subroutine epp_nucl_sub(evdw1,ees)
20928 !C
20929 !C This subroutine calculates the average interaction energy and its gradient
20930 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20931 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20932 !C The potential depends both on the distance of peptide-group centers and on
20933 !C the orientation of the CA-CA virtual bonds.
20934 !C
20935       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20936       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
20937                       sslipj,ssgradlipj,faclipij2
20938       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20939              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20940              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20941       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20942                 dist_temp, dist_init,sss_grad,fac,evdw1ij
20943       integer xshift,yshift,zshift
20944       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20945       real(kind=8) :: ees,eesij
20946 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20947       real(kind=8) scal_el /0.5d0/
20948       t_eelecij=0.0d0
20949       ees=0.0D0
20950       evdw1=0.0D0
20951       ind=0
20952 !c
20953 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20954 !c
20955 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20956       do i=iatel_s_nucl,iatel_e_nucl
20957       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20958       dxi=dc(1,i)
20959       dyi=dc(2,i)
20960       dzi=dc(3,i)
20961       dx_normi=dc_norm(1,i)
20962       dy_normi=dc_norm(2,i)
20963       dz_normi=dc_norm(3,i)
20964       xmedi=c(1,i)+0.5d0*dxi
20965       ymedi=c(2,i)+0.5d0*dyi
20966       zmedi=c(3,i)+0.5d0*dzi
20967         call to_box(xmedi,ymedi,zmedi)
20968         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
20969
20970       do j=ielstart_nucl(i),ielend_nucl(i)
20971         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20972         ind=ind+1
20973         dxj=dc(1,j)
20974         dyj=dc(2,j)
20975         dzj=dc(3,j)
20976 !          xj=c(1,j)+0.5D0*dxj-xmedi
20977 !          yj=c(2,j)+0.5D0*dyj-ymedi
20978 !          zj=c(3,j)+0.5D0*dzj-zmedi
20979         xj=c(1,j)+0.5D0*dxj
20980         yj=c(2,j)+0.5D0*dyj
20981         zj=c(3,j)+0.5D0*dzj
20982      call to_box(xj,yj,zj)
20983      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
20984       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
20985       xj=boxshift(xj-xmedi,boxxsize)
20986       yj=boxshift(yj-ymedi,boxysize)
20987       zj=boxshift(zj-zmedi,boxzsize)
20988         rij=xj*xj+yj*yj+zj*zj
20989 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20990         fac=(r0pp**2/rij)**3
20991         ev1=epspp*fac*fac
20992         ev2=epspp*fac
20993         evdw1ij=ev1-2*ev2
20994         fac=(-ev1-evdw1ij)/rij
20995 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20996         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20997         evdw1=evdw1+evdw1ij
20998 !C
20999 !C Calculate contributions to the Cartesian gradient.
21000 !C
21001         ggg(1)=fac*xj
21002         ggg(2)=fac*yj
21003         ggg(3)=fac*zj
21004         do k=1,3
21005           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21006           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21007         enddo
21008 !c phoshate-phosphate electrostatic interactions
21009         rij=dsqrt(rij)
21010         fac=1.0d0/rij
21011         eesij=dexp(-BEES*rij)*fac
21012 !          write (2,*)"fac",fac," eesijpp",eesij
21013         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21014         ees=ees+eesij
21015 !c          fac=-eesij*fac
21016         fac=-(fac+BEES)*eesij*fac
21017         ggg(1)=fac*xj
21018         ggg(2)=fac*yj
21019         ggg(3)=fac*zj
21020 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21021 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21022 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21023         do k=1,3
21024           gelpp(k,i)=gelpp(k,i)-ggg(k)
21025           gelpp(k,j)=gelpp(k,j)+ggg(k)
21026         enddo
21027       enddo ! j
21028       enddo   ! i
21029 !c      ees=332.0d0*ees
21030       ees=AEES*ees
21031       do i=nnt,nct
21032 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21033       do k=1,3
21034         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21035 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21036         gelpp(k,i)=AEES*gelpp(k,i)
21037       enddo
21038 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21039       enddo
21040 !c      write (2,*) "total EES",ees
21041       return
21042       end subroutine epp_nucl_sub
21043 !---------------------------------------------------------------------
21044       subroutine epsb(evdwpsb,eelpsb)
21045 !      use comm_locel
21046 !C
21047 !C This subroutine calculates the excluded-volume interaction energy between
21048 !C peptide-group centers and side chains and its gradient in virtual-bond and
21049 !C side-chain vectors.
21050 !C
21051       real(kind=8),dimension(3):: ggg
21052       integer :: i,iint,j,k,iteli,itypj,subchap
21053       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21054                e1,e2,evdwij,rij,evdwpsb,eelpsb
21055       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21056                 dist_temp, dist_init
21057       integer xshift,yshift,zshift
21058
21059 !cd    print '(a)','Enter ESCP'
21060 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21061       eelpsb=0.0d0
21062       evdwpsb=0.0d0
21063 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21064       do i=iatscp_s_nucl,iatscp_e_nucl
21065       if (itype(i,2).eq.ntyp1_molec(2) &
21066        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21067       xi=0.5D0*(c(1,i)+c(1,i+1))
21068       yi=0.5D0*(c(2,i)+c(2,i+1))
21069       zi=0.5D0*(c(3,i)+c(3,i+1))
21070         call to_box(xi,yi,zi)
21071
21072       do iint=1,nscp_gr_nucl(i)
21073
21074       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21075         itypj=itype(j,2)
21076         if (itypj.eq.ntyp1_molec(2)) cycle
21077 !C Uncomment following three lines for SC-p interactions
21078 !c         xj=c(1,nres+j)-xi
21079 !c         yj=c(2,nres+j)-yi
21080 !c         zj=c(3,nres+j)-zi
21081 !C Uncomment following three lines for Ca-p interactions
21082 !          xj=c(1,j)-xi
21083 !          yj=c(2,j)-yi
21084 !          zj=c(3,j)-zi
21085         xj=c(1,j)
21086         yj=c(2,j)
21087         zj=c(3,j)
21088         call to_box(xj,yj,zj)
21089       xj=boxshift(xj-xi,boxxsize)
21090       yj=boxshift(yj-yi,boxysize)
21091       zj=boxshift(zj-zi,boxzsize)
21092
21093       dist_init=xj**2+yj**2+zj**2
21094
21095         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21096         fac=rrij**expon2
21097         e1=fac*fac*aad_nucl(itypj)
21098         e2=fac*bad_nucl(itypj)
21099         if (iabs(j-i) .le. 2) then
21100           e1=scal14*e1
21101           e2=scal14*e2
21102         endif
21103         evdwij=e1+e2
21104         evdwpsb=evdwpsb+evdwij
21105         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21106            'evdw2',i,j,evdwij,"tu4"
21107 !C
21108 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21109 !C
21110         fac=-(evdwij+e1)*rrij
21111         ggg(1)=xj*fac
21112         ggg(2)=yj*fac
21113         ggg(3)=zj*fac
21114         do k=1,3
21115           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21116           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21117         enddo
21118       enddo
21119
21120       enddo ! iint
21121       enddo ! i
21122       do i=1,nct
21123       do j=1,3
21124         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21125         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21126       enddo
21127       enddo
21128       return
21129       end subroutine epsb
21130
21131 !------------------------------------------------------
21132       subroutine esb_gb(evdwsb,eelsb)
21133       use comm_locel
21134       use calc_data_nucl
21135       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21136       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21137       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21138       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21139                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21140       integer :: ii
21141       logical lprn
21142       evdw=0.0D0
21143       eelsb=0.0d0
21144       ecorr=0.0d0
21145       evdwsb=0.0D0
21146       lprn=.false.
21147       ind=0
21148 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21149       do i=iatsc_s_nucl,iatsc_e_nucl
21150       num_conti=0
21151       num_conti2=0
21152       itypi=itype(i,2)
21153 !        PRINT *,"I=",i,itypi
21154       if (itypi.eq.ntyp1_molec(2)) cycle
21155       itypi1=itype(i+1,2)
21156       xi=c(1,nres+i)
21157       yi=c(2,nres+i)
21158       zi=c(3,nres+i)
21159       call to_box(xi,yi,zi)
21160       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21161       dxi=dc_norm(1,nres+i)
21162       dyi=dc_norm(2,nres+i)
21163       dzi=dc_norm(3,nres+i)
21164       dsci_inv=vbld_inv(i+nres)
21165 !C
21166 !C Calculate SC interaction energy.
21167 !C
21168       do iint=1,nint_gr_nucl(i)
21169 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21170         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21171           ind=ind+1
21172 !            print *,"JESTEM"
21173           itypj=itype(j,2)
21174           if (itypj.eq.ntyp1_molec(2)) cycle
21175           dscj_inv=vbld_inv(j+nres)
21176           sig0ij=sigma_nucl(itypi,itypj)
21177           chi1=chi_nucl(itypi,itypj)
21178           chi2=chi_nucl(itypj,itypi)
21179           chi12=chi1*chi2
21180           chip1=chip_nucl(itypi,itypj)
21181           chip2=chip_nucl(itypj,itypi)
21182           chip12=chip1*chip2
21183 !            xj=c(1,nres+j)-xi
21184 !            yj=c(2,nres+j)-yi
21185 !            zj=c(3,nres+j)-zi
21186          xj=c(1,nres+j)
21187          yj=c(2,nres+j)
21188          zj=c(3,nres+j)
21189      call to_box(xj,yj,zj)
21190 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21191 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21192 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21193 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21194 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21195       xj=boxshift(xj-xi,boxxsize)
21196       yj=boxshift(yj-yi,boxysize)
21197       zj=boxshift(zj-zi,boxzsize)
21198
21199           dxj=dc_norm(1,nres+j)
21200           dyj=dc_norm(2,nres+j)
21201           dzj=dc_norm(3,nres+j)
21202           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21203           rij=dsqrt(rrij)
21204 !C Calculate angle-dependent terms of energy and contributions to their
21205 !C derivatives.
21206           erij(1)=xj*rij
21207           erij(2)=yj*rij
21208           erij(3)=zj*rij
21209           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21210           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21211           om12=dxi*dxj+dyi*dyj+dzi*dzj
21212           call sc_angular_nucl
21213           sigsq=1.0D0/sigsq
21214           sig=sig0ij*dsqrt(sigsq)
21215           rij_shift=1.0D0/rij-sig+sig0ij
21216 !            print *,rij_shift,"rij_shift"
21217 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21218 !c     &       " rij_shift",rij_shift
21219           if (rij_shift.le.0.0D0) then
21220             evdw=1.0D20
21221             return
21222           endif
21223           sigder=-sig*sigsq
21224 !c---------------------------------------------------------------
21225           rij_shift=1.0D0/rij_shift
21226           fac=rij_shift**expon
21227           e1=fac*fac*aa_nucl(itypi,itypj)
21228           e2=fac*bb_nucl(itypi,itypj)
21229           evdwij=eps1*eps2rt*(e1+e2)
21230 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21231 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21232           eps2der=evdwij
21233           evdwij=evdwij*eps2rt
21234           evdwsb=evdwsb+evdwij
21235           if (lprn) then
21236           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21237           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21238           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21239            restyp(itypi,2),i,restyp(itypj,2),j, &
21240            epsi,sigm,chi1,chi2,chip1,chip2, &
21241            eps1,eps2rt**2,sig,sig0ij, &
21242            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21243           evdwij
21244           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21245           endif
21246
21247           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21248                        'evdw',i,j,evdwij,"tu3"
21249
21250
21251 !C Calculate gradient components.
21252           e1=e1*eps1*eps2rt**2
21253           fac=-expon*(e1+evdwij)*rij_shift
21254           sigder=fac*sigder
21255           fac=rij*fac
21256 !c            fac=0.0d0
21257 !C Calculate the radial part of the gradient
21258           gg(1)=xj*fac
21259           gg(2)=yj*fac
21260           gg(3)=zj*fac
21261 !C Calculate angular part of the gradient.
21262           call sc_grad_nucl
21263           call eelsbij(eelij,num_conti2)
21264           if (energy_dec .and. &
21265          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21266         write (istat,'(e14.5)') evdwij
21267           eelsb=eelsb+eelij
21268         enddo      ! j
21269       enddo        ! iint
21270       num_cont_hb(i)=num_conti2
21271       enddo          ! i
21272 !c      write (iout,*) "Number of loop steps in EGB:",ind
21273 !cccc      energy_dec=.false.
21274       return
21275       end subroutine esb_gb
21276 !-------------------------------------------------------------------------------
21277       subroutine eelsbij(eesij,num_conti2)
21278       use comm_locel
21279       use calc_data_nucl
21280       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21281       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21282       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21283                 dist_temp, dist_init,rlocshield,fracinbuf
21284       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21285
21286 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21287       real(kind=8) scal_el /0.5d0/
21288       integer :: iteli,itelj,kkk,kkll,m,isubchap
21289       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21290       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21291       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21292               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21293               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21294               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21295               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21296               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21297               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21298               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21299       ind=ind+1
21300       itypi=itype(i,2)
21301       itypj=itype(j,2)
21302 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21303       ael6i=ael6_nucl(itypi,itypj)
21304       ael3i=ael3_nucl(itypi,itypj)
21305       ael63i=ael63_nucl(itypi,itypj)
21306       ael32i=ael32_nucl(itypi,itypj)
21307 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21308 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21309       dxj=dc(1,j+nres)
21310       dyj=dc(2,j+nres)
21311       dzj=dc(3,j+nres)
21312       dx_normi=dc_norm(1,i+nres)
21313       dy_normi=dc_norm(2,i+nres)
21314       dz_normi=dc_norm(3,i+nres)
21315       dx_normj=dc_norm(1,j+nres)
21316       dy_normj=dc_norm(2,j+nres)
21317       dz_normj=dc_norm(3,j+nres)
21318 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21319 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21320 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21321       if (ipot_nucl.ne.2) then
21322       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21323       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21324       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21325       else
21326       cosa=om12
21327       cosb=om1
21328       cosg=om2
21329       endif
21330       r3ij=rij*rrij
21331       r6ij=r3ij*r3ij
21332       fac=cosa-3.0D0*cosb*cosg
21333       facfac=fac*fac
21334       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21335       fac3=ael6i*r6ij
21336       fac4=ael3i*r3ij
21337       fac5=ael63i*r6ij
21338       fac6=ael32i*r6ij
21339 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21340 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21341       el1=fac3*(4.0D0+facfac-fac1)
21342       el2=fac4*fac
21343       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21344       el4=fac6*facfac
21345       eesij=el1+el2+el3+el4
21346 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21347       ees0ij=4.0D0+facfac-fac1
21348
21349       if (energy_dec) then
21350         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21351         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21352          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21353          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21354          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21355         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21356       endif
21357
21358 !C
21359 !C Calculate contributions to the Cartesian gradient.
21360 !C
21361       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21362       fac1=fac
21363 !c      erij(1)=xj*rmij
21364 !c      erij(2)=yj*rmij
21365 !c      erij(3)=zj*rmij
21366 !*
21367 !* Radial derivatives. First process both termini of the fragment (i,j)
21368 !*
21369       ggg(1)=facel*xj
21370       ggg(2)=facel*yj
21371       ggg(3)=facel*zj
21372       do k=1,3
21373       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21374       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21375       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21376       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21377       enddo
21378 !*
21379 !* Angular part
21380 !*
21381       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21382       fac4=-3.0D0*fac4
21383       fac3=-6.0D0*fac3
21384       fac5= 6.0d0*fac5
21385       fac6=-6.0d0*fac6
21386       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21387        fac6*fac1*cosg
21388       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21389        fac6*fac1*cosb
21390       do k=1,3
21391       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21392       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21393       enddo
21394       do k=1,3
21395       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21396       enddo
21397       do k=1,3
21398       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21399            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21400            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21401       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21402            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21403            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21404       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21405       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21406       enddo
21407 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21408        IF ( j.gt.i+1 .and.&
21409         num_conti.le.maxcont) THEN
21410 !C
21411 !C Calculate the contact function. The ith column of the array JCONT will
21412 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21413 !C greater than I). The arrays FACONT and GACONT will contain the values of
21414 !C the contact function and its derivative.
21415       r0ij=2.20D0*sigma_nucl(itypi,itypj)
21416 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21417       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21418 !c        write (2,*) "fcont",fcont
21419       if (fcont.gt.0.0D0) then
21420         num_conti=num_conti+1
21421         num_conti2=num_conti2+1
21422
21423         if (num_conti.gt.maxconts) then
21424           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21425                     ' will skip next contacts for this conf.',maxconts
21426         else
21427           jcont_hb(num_conti,i)=j
21428 !c            write (iout,*) "num_conti",num_conti,
21429 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21430 !C Calculate contact energies
21431           cosa4=4.0D0*cosa
21432           wij=cosa-3.0D0*cosb*cosg
21433           cosbg1=cosb+cosg
21434           cosbg2=cosb-cosg
21435           fac3=dsqrt(-ael6i)*r3ij
21436 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21437           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21438           if (ees0tmp.gt.0) then
21439             ees0pij=dsqrt(ees0tmp)
21440           else
21441             ees0pij=0
21442           endif
21443           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21444           if (ees0tmp.gt.0) then
21445             ees0mij=dsqrt(ees0tmp)
21446           else
21447             ees0mij=0
21448           endif
21449           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21450           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21451 !c            write (iout,*) "i",i," j",j,
21452 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21453           ees0pij1=fac3/ees0pij
21454           ees0mij1=fac3/ees0mij
21455           fac3p=-3.0D0*fac3*rrij
21456           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21457           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21458           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21459           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21460           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21461           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21462           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21463           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21464           ecosap=ecosa1+ecosa2
21465           ecosbp=ecosb1+ecosb2
21466           ecosgp=ecosg1+ecosg2
21467           ecosam=ecosa1-ecosa2
21468           ecosbm=ecosb1-ecosb2
21469           ecosgm=ecosg1-ecosg2
21470 !C End diagnostics
21471           facont_hb(num_conti,i)=fcont
21472           fprimcont=fprimcont/rij
21473           do k=1,3
21474             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21475             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21476           enddo
21477           gggp(1)=gggp(1)+ees0pijp*xj
21478           gggp(2)=gggp(2)+ees0pijp*yj
21479           gggp(3)=gggp(3)+ees0pijp*zj
21480           gggm(1)=gggm(1)+ees0mijp*xj
21481           gggm(2)=gggm(2)+ees0mijp*yj
21482           gggm(3)=gggm(3)+ees0mijp*zj
21483 !C Derivatives due to the contact function
21484           gacont_hbr(1,num_conti,i)=fprimcont*xj
21485           gacont_hbr(2,num_conti,i)=fprimcont*yj
21486           gacont_hbr(3,num_conti,i)=fprimcont*zj
21487           do k=1,3
21488 !c
21489 !c Gradient of the correlation terms
21490 !c
21491             gacontp_hb1(k,num_conti,i)= &
21492            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21493           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21494             gacontp_hb2(k,num_conti,i)= &
21495            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21496           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21497             gacontp_hb3(k,num_conti,i)=gggp(k)
21498             gacontm_hb1(k,num_conti,i)= &
21499            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21500           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21501             gacontm_hb2(k,num_conti,i)= &
21502            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21503           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21504             gacontm_hb3(k,num_conti,i)=gggm(k)
21505           enddo
21506         endif
21507       endif
21508       ENDIF
21509       return
21510       end subroutine eelsbij
21511 !------------------------------------------------------------------
21512       subroutine sc_grad_nucl
21513       use comm_locel
21514       use calc_data_nucl
21515       real(kind=8),dimension(3) :: dcosom1,dcosom2
21516       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21517       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21518       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21519       do k=1,3
21520       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21521       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21522       enddo
21523       do k=1,3
21524       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21525       enddo
21526       do k=1,3
21527       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21528              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21529              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21530       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21531              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21532              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21533       enddo
21534 !C
21535 !C Calculate the components of the gradient in DC and X
21536 !C
21537       do l=1,3
21538       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21539       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21540       enddo
21541       return
21542       end subroutine sc_grad_nucl
21543 !-----------------------------------------------------------------------
21544       subroutine esb(esbloc)
21545 !C Calculate the local energy of a side chain and its derivatives in the
21546 !C corresponding virtual-bond valence angles THETA and the spherical angles
21547 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21548 !C added by Urszula Kozlowska. 07/11/2007
21549 !C
21550       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21551       real(kind=8),dimension(9):: x
21552      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21553       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21554       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21555       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21556        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21557        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21558        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21559        integer::it,nlobit,i,j,k
21560 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21561       delta=0.02d0*pi
21562       esbloc=0.0D0
21563       do i=loc_start_nucl,loc_end_nucl
21564       if (itype(i,2).eq.ntyp1_molec(2)) cycle
21565       costtab(i+1) =dcos(theta(i+1))
21566       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21567       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21568       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21569       cosfac2=0.5d0/(1.0d0+costtab(i+1))
21570       cosfac=dsqrt(cosfac2)
21571       sinfac2=0.5d0/(1.0d0-costtab(i+1))
21572       sinfac=dsqrt(sinfac2)
21573       it=itype(i,2)
21574       if (it.eq.10) goto 1
21575
21576 !c
21577 !C  Compute the axes of tghe local cartesian coordinates system; store in
21578 !c   x_prime, y_prime and z_prime
21579 !c
21580       do j=1,3
21581         x_prime(j) = 0.00
21582         y_prime(j) = 0.00
21583         z_prime(j) = 0.00
21584       enddo
21585 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21586 !C     &   dc_norm(3,i+nres)
21587       do j = 1,3
21588         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21589         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21590       enddo
21591       do j = 1,3
21592         z_prime(j) = -uz(j,i-1)
21593 !           z_prime(j)=0.0
21594       enddo
21595
21596       xx=0.0d0
21597       yy=0.0d0
21598       zz=0.0d0
21599       do j = 1,3
21600         xx = xx + x_prime(j)*dc_norm(j,i+nres)
21601         yy = yy + y_prime(j)*dc_norm(j,i+nres)
21602         zz = zz + z_prime(j)*dc_norm(j,i+nres)
21603       enddo
21604
21605       xxtab(i)=xx
21606       yytab(i)=yy
21607       zztab(i)=zz
21608        it=itype(i,2)
21609       do j = 1,9
21610         x(j) = sc_parmin_nucl(j,it)
21611       enddo
21612 #ifdef CHECK_COORD
21613 !Cc diagnostics - remove later
21614       xx1 = dcos(alph(2))
21615       yy1 = dsin(alph(2))*dcos(omeg(2))
21616       zz1 = -dsin(alph(2))*dsin(omeg(2))
21617       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21618        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21619        xx1,yy1,zz1
21620 !C,"  --- ", xx_w,yy_w,zz_w
21621 !c end diagnostics
21622 #endif
21623       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21624       esbloc = esbloc + sumene
21625       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21626 !        print *,"enecomp",sumene,sumene2
21627 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21628 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21629 #ifdef DEBUG
21630       write (2,*) "x",(x(k),k=1,9)
21631 !C
21632 !C This section to check the numerical derivatives of the energy of ith side
21633 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21634 !C #define DEBUG in the code to turn it on.
21635 !C
21636       write (2,*) "sumene               =",sumene
21637       aincr=1.0d-7
21638       xxsave=xx
21639       xx=xx+aincr
21640       write (2,*) xx,yy,zz
21641       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21642       de_dxx_num=(sumenep-sumene)/aincr
21643       xx=xxsave
21644       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21645       yysave=yy
21646       yy=yy+aincr
21647       write (2,*) xx,yy,zz
21648       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21649       de_dyy_num=(sumenep-sumene)/aincr
21650       yy=yysave
21651       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21652       zzsave=zz
21653       zz=zz+aincr
21654       write (2,*) xx,yy,zz
21655       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21656       de_dzz_num=(sumenep-sumene)/aincr
21657       zz=zzsave
21658       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21659       costsave=cost2tab(i+1)
21660       sintsave=sint2tab(i+1)
21661       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21662       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21663       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21664       de_dt_num=(sumenep-sumene)/aincr
21665       write (2,*) " t+ sumene from enesc=",sumenep,sumene
21666       cost2tab(i+1)=costsave
21667       sint2tab(i+1)=sintsave
21668 !C End of diagnostics section.
21669 #endif
21670 !C
21671 !C Compute the gradient of esc
21672 !C
21673       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21674       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21675       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21676       de_dtt=0.0d0
21677 #ifdef DEBUG
21678       write (2,*) "x",(x(k),k=1,9)
21679       write (2,*) "xx",xx," yy",yy," zz",zz
21680       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21681         " de_zz   ",de_zz," de_tt   ",de_tt
21682       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21683         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21684 #endif
21685 !C
21686        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21687        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21688        cosfac2xx=cosfac2*xx
21689        sinfac2yy=sinfac2*yy
21690        do k = 1,3
21691        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21692          vbld_inv(i+1)
21693        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21694          vbld_inv(i)
21695        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21696        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21697 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21698 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21699 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21700 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21701        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21702        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21703        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21704        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21705        dZZ_Ci1(k)=0.0d0
21706        dZZ_Ci(k)=0.0d0
21707        do j=1,3
21708          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21709          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21710        enddo
21711
21712        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21713        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21714        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21715 !c
21716        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21717        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21718        enddo
21719
21720        do k=1,3
21721        dXX_Ctab(k,i)=dXX_Ci(k)
21722        dXX_C1tab(k,i)=dXX_Ci1(k)
21723        dYY_Ctab(k,i)=dYY_Ci(k)
21724        dYY_C1tab(k,i)=dYY_Ci1(k)
21725        dZZ_Ctab(k,i)=dZZ_Ci(k)
21726        dZZ_C1tab(k,i)=dZZ_Ci1(k)
21727        dXX_XYZtab(k,i)=dXX_XYZ(k)
21728        dYY_XYZtab(k,i)=dYY_XYZ(k)
21729        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21730        enddo
21731        do k = 1,3
21732 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21733 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21734 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21735 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21736 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21737 !c     &    dt_dci(k)
21738 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21739 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21740        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21741        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21742        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21743        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21744        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21745        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21746 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21747        enddo
21748 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21749 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21750
21751 !C to check gradient call subroutine check_grad
21752
21753     1 continue
21754       enddo
21755       return
21756       end subroutine esb
21757 !=-------------------------------------------------------
21758       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21759 !      implicit none
21760       real(kind=8),dimension(9):: x(9)
21761        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21762       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21763       integer i
21764 !c      write (2,*) "enesc"
21765 !c      write (2,*) "x",(x(i),i=1,9)
21766 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21767       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21768       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21769       + x(9)*yy*zz
21770       enesc_nucl=sumene
21771       return
21772       end function enesc_nucl
21773 !-----------------------------------------------------------------------------
21774       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21775 #ifdef MPI
21776       include 'mpif.h'
21777       integer,parameter :: max_cont=2000
21778       integer,parameter:: max_dim=2*(8*3+6)
21779       integer, parameter :: msglen1=max_cont*max_dim
21780       integer,parameter :: msglen2=2*msglen1
21781       integer source,CorrelType,CorrelID,Error
21782       real(kind=8) :: buffer(max_cont,max_dim)
21783       integer status(MPI_STATUS_SIZE)
21784       integer :: ierror,nbytes
21785 #endif
21786       real(kind=8),dimension(3):: gx(3),gx1(3)
21787       real(kind=8) :: time00
21788       logical lprn,ldone
21789       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21790       real(kind=8) ecorr,ecorr3
21791       integer :: n_corr,n_corr1,mm,msglen
21792 !C Set lprn=.true. for debugging
21793       lprn=.false.
21794       n_corr=0
21795       n_corr1=0
21796 #ifdef MPI
21797       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21798
21799       if (nfgtasks.le.1) goto 30
21800       if (lprn) then
21801       write (iout,'(a)') 'Contact function values:'
21802       do i=nnt,nct-1
21803         write (iout,'(2i3,50(1x,i2,f5.2))')  &
21804        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21805        j=1,num_cont_hb(i))
21806       enddo
21807       endif
21808 !C Caution! Following code assumes that electrostatic interactions concerning
21809 !C a given atom are split among at most two processors!
21810       CorrelType=477
21811       CorrelID=fg_rank+1
21812       ldone=.false.
21813       do i=1,max_cont
21814       do j=1,max_dim
21815         buffer(i,j)=0.0D0
21816       enddo
21817       enddo
21818       mm=mod(fg_rank,2)
21819 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21820       if (mm) 20,20,10
21821    10 continue
21822 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21823       if (fg_rank.gt.0) then
21824 !C Send correlation contributions to the preceding processor
21825       msglen=msglen1
21826       nn=num_cont_hb(iatel_s_nucl)
21827       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21828 !c        write (*,*) 'The BUFFER array:'
21829 !c        do i=1,nn
21830 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21831 !c        enddo
21832       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21833         msglen=msglen2
21834         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21835 !C Clear the contacts of the atom passed to the neighboring processor
21836       nn=num_cont_hb(iatel_s_nucl+1)
21837 !c        do i=1,nn
21838 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21839 !c        enddo
21840           num_cont_hb(iatel_s_nucl)=0
21841       endif
21842 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21843 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21844 !cd   & ' msglen=',msglen
21845 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21846 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21847 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21848       time00=MPI_Wtime()
21849       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21850        CorrelType,FG_COMM,IERROR)
21851       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21852 !cd      write (iout,*) 'Processor ',fg_rank,
21853 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21854 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21855 !c        write (*,*) 'Processor ',fg_rank,
21856 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21857 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21858 !c        msglen=msglen1
21859       endif ! (fg_rank.gt.0)
21860       if (ldone) goto 30
21861       ldone=.true.
21862    20 continue
21863 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21864       if (fg_rank.lt.nfgtasks-1) then
21865 !C Receive correlation contributions from the next processor
21866       msglen=msglen1
21867       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21868 !cd      write (iout,*) 'Processor',fg_rank,
21869 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21870 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21871 !c        write (*,*) 'Processor',fg_rank,
21872 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21873 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21874       time00=MPI_Wtime()
21875       nbytes=-1
21876       do while (nbytes.le.0)
21877         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21878         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21879       enddo
21880 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21881       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21882        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21883       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21884 !c        write (*,*) 'Processor',fg_rank,
21885 !c     &' has received correlation contribution from processor',fg_rank+1,
21886 !c     & ' msglen=',msglen,' nbytes=',nbytes
21887 !c        write (*,*) 'The received BUFFER array:'
21888 !c        do i=1,max_cont
21889 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21890 !c        enddo
21891       if (msglen.eq.msglen1) then
21892         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21893       else if (msglen.eq.msglen2)  then
21894         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21895         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21896       else
21897         write (iout,*) &
21898       'ERROR!!!! message length changed while processing correlations.'
21899         write (*,*) &
21900       'ERROR!!!! message length changed while processing correlations.'
21901         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21902       endif ! msglen.eq.msglen1
21903       endif ! fg_rank.lt.nfgtasks-1
21904       if (ldone) goto 30
21905       ldone=.true.
21906       goto 10
21907    30 continue
21908 #endif
21909       if (lprn) then
21910       write (iout,'(a)') 'Contact function values:'
21911       do i=nnt_molec(2),nct_molec(2)-1
21912         write (iout,'(2i3,50(1x,i2,f5.2))') &
21913        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21914        j=1,num_cont_hb(i))
21915       enddo
21916       endif
21917       ecorr=0.0D0
21918       ecorr3=0.0d0
21919 !C Remove the loop below after debugging !!!
21920 !      do i=nnt_molec(2),nct_molec(2)
21921 !        do j=1,3
21922 !          gradcorr_nucl(j,i)=0.0D0
21923 !          gradxorr_nucl(j,i)=0.0D0
21924 !          gradcorr3_nucl(j,i)=0.0D0
21925 !          gradxorr3_nucl(j,i)=0.0D0
21926 !        enddo
21927 !      enddo
21928 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21929 !C Calculate the local-electrostatic correlation terms
21930       do i=iatsc_s_nucl,iatsc_e_nucl
21931       i1=i+1
21932       num_conti=num_cont_hb(i)
21933       num_conti1=num_cont_hb(i+1)
21934 !        print *,i,num_conti,num_conti1
21935       do jj=1,num_conti
21936         j=jcont_hb(jj,i)
21937         do kk=1,num_conti1
21938           j1=jcont_hb(kk,i1)
21939 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21940 !c     &         ' jj=',jj,' kk=',kk
21941           if (j1.eq.j+1 .or. j1.eq.j-1) then
21942 !C
21943 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21944 !C The system gains extra energy.
21945 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21946 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21947 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21948 !C
21949             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21950             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21951              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21952             n_corr=n_corr+1
21953           else if (j1.eq.j) then
21954 !C
21955 !C Contacts I-J and I-(J+1) occur simultaneously.
21956 !C The system loses extra energy.
21957 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21958 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21959 !C Need to implement full formulas 32 from Liwo et al., 1998.
21960 !C
21961 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21962 !c     &         ' jj=',jj,' kk=',kk
21963             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21964           endif
21965         enddo ! kk
21966         do kk=1,num_conti
21967           j1=jcont_hb(kk,i)
21968 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21969 !c     &         ' jj=',jj,' kk=',kk
21970           if (j1.eq.j+1) then
21971 !C Contacts I-J and (I+1)-J occur simultaneously.
21972 !C The system loses extra energy.
21973             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21974           endif ! j1==j+1
21975         enddo ! kk
21976       enddo ! jj
21977       enddo ! i
21978       return
21979       end subroutine multibody_hb_nucl
21980 !-----------------------------------------------------------
21981       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21982 !      implicit real*8 (a-h,o-z)
21983 !      include 'DIMENSIONS'
21984 !      include 'COMMON.IOUNITS'
21985 !      include 'COMMON.DERIV'
21986 !      include 'COMMON.INTERACT'
21987 !      include 'COMMON.CONTACTS'
21988       real(kind=8),dimension(3) :: gx,gx1
21989       logical :: lprn
21990 !el local variables
21991       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21992       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21993                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21994                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21995                rlocshield
21996
21997       lprn=.false.
21998       eij=facont_hb(jj,i)
21999       ekl=facont_hb(kk,k)
22000       ees0pij=ees0p(jj,i)
22001       ees0pkl=ees0p(kk,k)
22002       ees0mij=ees0m(jj,i)
22003       ees0mkl=ees0m(kk,k)
22004       ekont=eij*ekl
22005       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22006 !      print *,"ehbcorr_nucl",ekont,ees
22007 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22008 !C Following 4 lines for diagnostics.
22009 !cd    ees0pkl=0.0D0
22010 !cd    ees0pij=1.0D0
22011 !cd    ees0mkl=0.0D0
22012 !cd    ees0mij=1.0D0
22013 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22014 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22015 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22016 !C Calculate the multi-body contribution to energy.
22017 !      ecorr_nucl=ecorr_nucl+ekont*ees
22018 !C Calculate multi-body contributions to the gradient.
22019       coeffpees0pij=coeffp*ees0pij
22020       coeffmees0mij=coeffm*ees0mij
22021       coeffpees0pkl=coeffp*ees0pkl
22022       coeffmees0mkl=coeffm*ees0mkl
22023       do ll=1,3
22024       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22025        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22026        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22027       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22028       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22029       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22030       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22031       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22032       coeffmees0mij*gacontm_hb1(ll,kk,k))
22033       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22034       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22035       coeffmees0mij*gacontm_hb2(ll,kk,k))
22036       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22037         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22038         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22039       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22040       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22041       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22042         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22043         coeffmees0mij*gacontm_hb3(ll,kk,k))
22044       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22045       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22046       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22047       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22048       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22049       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22050       enddo
22051       ehbcorr_nucl=ekont*ees
22052       return
22053       end function ehbcorr_nucl
22054 !-------------------------------------------------------------------------
22055
22056      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22057 !      implicit real*8 (a-h,o-z)
22058 !      include 'DIMENSIONS'
22059 !      include 'COMMON.IOUNITS'
22060 !      include 'COMMON.DERIV'
22061 !      include 'COMMON.INTERACT'
22062 !      include 'COMMON.CONTACTS'
22063       real(kind=8),dimension(3) :: gx,gx1
22064       logical :: lprn
22065 !el local variables
22066       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22067       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22068                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22069                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22070                rlocshield
22071
22072       lprn=.false.
22073       eij=facont_hb(jj,i)
22074       ekl=facont_hb(kk,k)
22075       ees0pij=ees0p(jj,i)
22076       ees0pkl=ees0p(kk,k)
22077       ees0mij=ees0m(jj,i)
22078       ees0mkl=ees0m(kk,k)
22079       ekont=eij*ekl
22080       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22081 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22082 !C Following 4 lines for diagnostics.
22083 !cd    ees0pkl=0.0D0
22084 !cd    ees0pij=1.0D0
22085 !cd    ees0mkl=0.0D0
22086 !cd    ees0mij=1.0D0
22087 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22088 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22089 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22090 !C Calculate the multi-body contribution to energy.
22091 !      ecorr=ecorr+ekont*ees
22092 !C Calculate multi-body contributions to the gradient.
22093       coeffpees0pij=coeffp*ees0pij
22094       coeffmees0mij=coeffm*ees0mij
22095       coeffpees0pkl=coeffp*ees0pkl
22096       coeffmees0mkl=coeffm*ees0mkl
22097       do ll=1,3
22098       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22099        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22100        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22101       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22102       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22103       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22104       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22105       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22106       coeffmees0mij*gacontm_hb1(ll,kk,k))
22107       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22108       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22109       coeffmees0mij*gacontm_hb2(ll,kk,k))
22110       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22111         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22112         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22113       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22114       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22115       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22116         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22117         coeffmees0mij*gacontm_hb3(ll,kk,k))
22118       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22119       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22120       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22121       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22122       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22123       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22124       enddo
22125       ehbcorr3_nucl=ekont*ees
22126       return
22127       end function ehbcorr3_nucl
22128 #ifdef MPI
22129       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22130       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22131       real(kind=8):: buffer(dimen1,dimen2)
22132       num_kont=num_cont_hb(atom)
22133       do i=1,num_kont
22134       do k=1,8
22135         do j=1,3
22136           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22137         enddo ! j
22138       enddo ! k
22139       buffer(i,indx+25)=facont_hb(i,atom)
22140       buffer(i,indx+26)=ees0p(i,atom)
22141       buffer(i,indx+27)=ees0m(i,atom)
22142       buffer(i,indx+28)=d_cont(i,atom)
22143       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22144       enddo ! i
22145       buffer(1,indx+30)=dfloat(num_kont)
22146       return
22147       end subroutine pack_buffer
22148 !c------------------------------------------------------------------------------
22149       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22150       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22151       real(kind=8):: buffer(dimen1,dimen2)
22152 !      double precision zapas
22153 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22154 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22155 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22156 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22157       num_kont=buffer(1,indx+30)
22158       num_kont_old=num_cont_hb(atom)
22159       num_cont_hb(atom)=num_kont+num_kont_old
22160       do i=1,num_kont
22161       ii=i+num_kont_old
22162       do k=1,8
22163         do j=1,3
22164           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22165         enddo ! j
22166       enddo ! k
22167       facont_hb(ii,atom)=buffer(i,indx+25)
22168       ees0p(ii,atom)=buffer(i,indx+26)
22169       ees0m(ii,atom)=buffer(i,indx+27)
22170       d_cont(i,atom)=buffer(i,indx+28)
22171       jcont_hb(ii,atom)=buffer(i,indx+29)
22172       enddo ! i
22173       return
22174       end subroutine unpack_buffer
22175 !c------------------------------------------------------------------------------
22176 #endif
22177       subroutine ecatcat(ecationcation)
22178       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22179       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22180       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22181       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22182       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22183       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22184       gg,r
22185
22186       ecationcation=0.0d0
22187       if (nres_molec(5).eq.0) return
22188       rcat0=3.472
22189       epscalc=0.05
22190       r06 = rcat0**6
22191       r012 = r06**2
22192 !        k0 = 332.0*(2.0*2.0)/80.0
22193       itmp=0
22194
22195       do i=1,4
22196       itmp=itmp+nres_molec(i)
22197       enddo
22198 !        write(iout,*) "itmp",itmp
22199       do i=itmp+1,itmp+nres_molec(5)-1
22200
22201       xi=c(1,i)
22202       yi=c(2,i)
22203       zi=c(3,i)
22204 !        write (iout,*) i,"TUTUT",c(1,i)
22205         itypi=itype(i,5)
22206       call to_box(xi,yi,zi)
22207       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22208         do j=i+1,itmp+nres_molec(5)
22209         itypj=itype(j,5)
22210 !          print *,i,j,itypi,itypj
22211         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22212 !           print *,i,j,'catcat'
22213          xj=c(1,j)
22214          yj=c(2,j)
22215          zj=c(3,j)
22216       call to_box(xj,yj,zj)
22217 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22218 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22219 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22220 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22221 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22222       xj=boxshift(xj-xi,boxxsize)
22223       yj=boxshift(yj-yi,boxysize)
22224       zj=boxshift(zj-zi,boxzsize)
22225        rcal =xj**2+yj**2+zj**2
22226       ract=sqrt(rcal)
22227 !        rcat0=3.472
22228 !        epscalc=0.05
22229 !        r06 = rcat0**6
22230 !        r012 = r06**2
22231 !        k0 = 332*(2*2)/80
22232       Evan1cat=epscalc*(r012/(rcal**6))
22233       Evan2cat=epscalc*2*(r06/(rcal**3))
22234       Eeleccat=k0/ract
22235       r7 = rcal**7
22236       r4 = rcal**4
22237       r(1)=xj
22238       r(2)=yj
22239       r(3)=zj
22240       do k=1,3
22241         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22242         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22243         dEeleccat(k)=-k0*r(k)/ract**3
22244       enddo
22245       do k=1,3
22246         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22247         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22248         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22249       enddo
22250       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22251        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22252 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22253       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22254        enddo
22255        enddo
22256        return
22257        end subroutine ecatcat
22258 !---------------------------------------------------------------------------
22259 ! new for K+
22260       subroutine ecats_prot_amber(evdw)
22261 !      subroutine ecat_prot2(ecation_prot)
22262       use calc_data
22263       use comm_momo
22264
22265       logical :: lprn
22266 !el local variables
22267       integer :: iint,itypi1,subchap,isel,itmp
22268       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22269       real(kind=8) :: evdw,aa,bb
22270       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22271                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22272                 sslipi,sslipj,faclip,alpha_sco
22273       integer :: ii
22274       real(kind=8) :: fracinbuf
22275       real (kind=8) :: escpho
22276       real (kind=8),dimension(4):: ener
22277       real(kind=8) :: b1,b2,egb
22278       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22279        Lambf,&
22280        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22281        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22282        federmaus,&
22283        d1i,d1j
22284 !       real(kind=8),dimension(3,2)::erhead_tail
22285 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22286       real(kind=8) ::  facd4, adler, Fgb, facd3
22287       integer troll,jj,istate
22288       real (kind=8) :: dcosom1(3),dcosom2(3)
22289       real(kind=8) ::locbox(3)
22290       locbox(1)=boxxsize
22291           locbox(2)=boxysize
22292       locbox(3)=boxzsize
22293
22294       evdw=0.0D0
22295       if (nres_molec(5).eq.0) return
22296       eps_out=80.0d0
22297 !      sss_ele_cut=1.0d0
22298
22299       itmp=0
22300       do i=1,4
22301       itmp=itmp+nres_molec(i)
22302       enddo
22303 !        go to 17
22304 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22305       do i=ibond_start,ibond_end
22306
22307 !        print *,"I am in EVDW",i
22308       itypi=iabs(itype(i,1))
22309
22310 !        if (i.ne.47) cycle
22311       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22312       itypi1=iabs(itype(i+1,1))
22313       xi=c(1,nres+i)
22314       yi=c(2,nres+i)
22315       zi=c(3,nres+i)
22316       call to_box(xi,yi,zi)
22317       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22318       dxi=dc_norm(1,nres+i)
22319       dyi=dc_norm(2,nres+i)
22320       dzi=dc_norm(3,nres+i)
22321       dsci_inv=vbld_inv(i+nres)
22322        do j=itmp+1,itmp+nres_molec(5)
22323
22324 ! Calculate SC interaction energy.
22325           itypj=iabs(itype(j,5))
22326           if ((itypj.eq.ntyp1)) cycle
22327            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22328
22329           dscj_inv=0.0
22330          xj=c(1,j)
22331          yj=c(2,j)
22332          zj=c(3,j)
22333
22334       call to_box(xj,yj,zj)
22335 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
22336
22337 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22338 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22339 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22340 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22341 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22342       xj=boxshift(xj-xi,boxxsize)
22343       yj=boxshift(yj-yi,boxysize)
22344       zj=boxshift(zj-zi,boxzsize)
22345 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
22346
22347 !          dxj = dc_norm( 1, nres+j )
22348 !          dyj = dc_norm( 2, nres+j )
22349 !          dzj = dc_norm( 3, nres+j )
22350
22351         itypi = itype(i,1)
22352         itypj = itype(j,5)
22353 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22354 ! sampling performed with amber package
22355 !          alf1   = 0.0d0
22356 !          alf2   = 0.0d0
22357 !          alf12  = 0.0d0
22358 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22359         chi1 = chi1cat(itypi,itypj)
22360         chis1 = chis1cat(itypi,itypj)
22361         chip1 = chipp1cat(itypi,itypj)
22362 !          chi1=0.0d0
22363 !          chis1=0.0d0
22364 !          chip1=0.0d0
22365         chi2=0.0
22366         chip2=0.0
22367         chis2=0.0
22368 !          chis2 = chis(itypj,itypi)
22369         chis12 = chis1 * chis2
22370         sig1 = sigmap1cat(itypi,itypj)
22371 !          sig2 = sigmap2(itypi,itypj)
22372 ! alpha factors from Fcav/Gcav
22373         b1cav = alphasurcat(1,itypi,itypj)
22374         b2cav = alphasurcat(2,itypi,itypj)
22375         b3cav = alphasurcat(3,itypi,itypj)
22376         b4cav = alphasurcat(4,itypi,itypj)
22377
22378 ! used to determine whether we want to do quadrupole calculations
22379        eps_in = epsintabcat(itypi,itypj)
22380        if (eps_in.eq.0.0) eps_in=1.0
22381
22382        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22383 !       Rtail = 0.0d0
22384
22385        DO k = 1, 3
22386       ctail(k,1)=c(k,i+nres)
22387       ctail(k,2)=c(k,j)
22388        END DO
22389       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
22390       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
22391 !c! tail distances will be themselves usefull elswhere
22392 !c1 (in Gcav, for example)
22393        do k=1,3
22394        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
22395        enddo
22396        Rtail = dsqrt( &
22397         (Rtail_distance(1)*Rtail_distance(1)) &
22398       + (Rtail_distance(2)*Rtail_distance(2)) &
22399       + (Rtail_distance(3)*Rtail_distance(3)))
22400 ! tail location and distance calculations
22401 ! dhead1
22402        d1 = dheadcat(1, 1, itypi, itypj)
22403 !       d2 = dhead(2, 1, itypi, itypj)
22404        DO k = 1,3
22405 ! location of polar head is computed by taking hydrophobic centre
22406 ! and moving by a d1 * dc_norm vector
22407 ! see unres publications for very informative images
22408       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22409       chead(k,2) = c(k, j)
22410       enddo
22411       call to_box(chead(1,1),chead(2,1),chead(3,1))
22412       call to_box(chead(1,2),chead(2,2),chead(3,2))
22413 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
22414 ! distance
22415 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22416 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22417       do k=1,3
22418       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
22419        END DO
22420 ! pitagoras (root of sum of squares)
22421        Rhead = dsqrt( &
22422         (Rhead_distance(1)*Rhead_distance(1)) &
22423       + (Rhead_distance(2)*Rhead_distance(2)) &
22424       + (Rhead_distance(3)*Rhead_distance(3)))
22425 !-------------------------------------------------------------------
22426 ! zero everything that should be zero'ed
22427        evdwij = 0.0d0
22428        ECL = 0.0d0
22429        Elj = 0.0d0
22430        Equad = 0.0d0
22431        Epol = 0.0d0
22432        Fcav=0.0d0
22433        eheadtail = 0.0d0
22434        dGCLdOM1 = 0.0d0
22435        dGCLdOM2 = 0.0d0
22436        dGCLdOM12 = 0.0d0
22437        dPOLdOM1 = 0.0d0
22438        dPOLdOM2 = 0.0d0
22439         Fcav = 0.0d0
22440         Fisocav=0.0d0
22441         dFdR = 0.0d0
22442         dCAVdOM1  = 0.0d0
22443         dCAVdOM2  = 0.0d0
22444         dCAVdOM12 = 0.0d0
22445         dscj_inv = vbld_inv(j+nres)
22446 !          print *,i,j,dscj_inv,dsci_inv
22447 ! rij holds 1/(distance of Calpha atoms)
22448         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22449         rij  = dsqrt(rrij)
22450         CALL sc_angular
22451 ! this should be in elgrad_init but om's are calculated by sc_angular
22452 ! which in turn is used by older potentials
22453 ! om = omega, sqom = om^2
22454         sqom1  = om1 * om1
22455         sqom2  = om2 * om2
22456         sqom12 = om12 * om12
22457
22458 ! now we calculate EGB - Gey-Berne
22459 ! It will be summed up in evdwij and saved in evdw
22460         sigsq     = 1.0D0  / sigsq
22461         sig       = sig0ij * dsqrt(sigsq)
22462 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22463         rij_shift = Rtail - sig + sig0ij
22464         IF (rij_shift.le.0.0D0) THEN
22465          evdw = 1.0D20
22466       if (evdw.gt.1.0d6) then
22467       write (*,'(2(1x,a3,i3),7f7.2)') &
22468       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22469       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
22470       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
22471      write(*,*) "ANISO?!",chi1
22472 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22473 !      Equad,evdwij+Fcav+eheadtail,evdw
22474       endif
22475
22476          RETURN
22477         END IF
22478         sigder = -sig * sigsq
22479         rij_shift = 1.0D0 / rij_shift
22480         fac       = rij_shift**expon
22481         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22482 !          print *,"ADAM",aa_aq(itypi,itypj)
22483
22484 !          c1        = 0.0d0
22485         c2        = fac  * bb_aq_cat(itypi,itypj)
22486 !          c2        = 0.0d0
22487         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22488         eps2der   = eps3rt * evdwij
22489         eps3der   = eps2rt * evdwij
22490 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22491         evdwij    = eps2rt * eps3rt * evdwij
22492 !#ifdef TSCSC
22493 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22494 !           evdw_p = evdw_p + evdwij
22495 !          ELSE
22496 !           evdw_m = evdw_m + evdwij
22497 !          END IF
22498 !#else
22499         evdw = evdw  &
22500             + evdwij
22501 !#endif
22502         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22503         fac    = -expon * (c1 + evdwij) * rij_shift
22504         sigder = fac * sigder
22505 ! Calculate distance derivative
22506         gg(1) =  fac
22507         gg(2) =  fac
22508         gg(3) =  fac
22509
22510         fac = chis1 * sqom1 + chis2 * sqom2 &
22511         - 2.0d0 * chis12 * om1 * om2 * om12
22512         pom = 1.0d0 - chis1 * chis2 * sqom12
22513         Lambf = (1.0d0 - (fac / pom))
22514         Lambf = dsqrt(Lambf)
22515         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22516         Chif = Rtail * sparrow
22517         ChiLambf = Chif * Lambf
22518         eagle = dsqrt(ChiLambf)
22519         bat = ChiLambf ** 11.0d0
22520         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22521         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22522         botsq = bot * bot
22523         Fcav = top / bot
22524
22525        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22526        dbot = 12.0d0 * b4cav * bat * Lambf
22527        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22528
22529         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22530         dbot = 12.0d0 * b4cav * bat * Chif
22531         eagle = Lambf * pom
22532         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22533         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22534         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22535             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22536
22537         dFdL = ((dtop * bot - top * dbot) / botsq)
22538         dCAVdOM1  = dFdL * ( dFdOM1 )
22539         dCAVdOM2  = dFdL * ( dFdOM2 )
22540         dCAVdOM12 = dFdL * ( dFdOM12 )
22541
22542        DO k= 1, 3
22543       ertail(k) = Rtail_distance(k)/Rtail
22544        END DO
22545        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22546        erdxj = scalar( ertail(1), dC_norm(1,j) )
22547        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
22548        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22549        DO k = 1, 3
22550       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22551       gradpepcatx(k,i) = gradpepcatx(k,i) &
22552               - (( dFdR + gg(k) ) * pom)
22553       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22554 !        gvdwx(k,j) = gvdwx(k,j)   &
22555 !                  + (( dFdR + gg(k) ) * pom)
22556       gradpepcat(k,i) = gradpepcat(k,i)  &
22557               - (( dFdR + gg(k) ) * ertail(k))
22558       gradpepcat(k,j) = gradpepcat(k,j) &
22559               + (( dFdR + gg(k) ) * ertail(k))
22560       gg(k) = 0.0d0
22561        ENDDO
22562 !c! Compute head-head and head-tail energies for each state
22563         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
22564         IF (isel.eq.0) THEN
22565 !c! No charges - do nothing
22566          eheadtail = 0.0d0
22567
22568         ELSE IF (isel.eq.1) THEN
22569 !c! Nonpolar-charge interactions
22570         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22571           Qi=Qi*2
22572           Qij=Qij*2
22573          endif
22574         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22575           Qj=Qj*2
22576           Qij=Qij*2
22577          endif
22578
22579          CALL enq_cat(epol)
22580          eheadtail = epol
22581 !           eheadtail = 0.0d0
22582
22583         ELSE IF (isel.eq.3) THEN
22584 !c! Dipole-charge interactions
22585         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22586           Qi=Qi*2
22587           Qij=Qij*2
22588          endif
22589         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22590           Qj=Qj*2
22591           Qij=Qij*2
22592          endif
22593 !         write(iout,*) "KURWA0",d1
22594
22595          CALL edq_cat(ecl, elj, epol)
22596         eheadtail = ECL + elj + epol
22597 !           eheadtail = 0.0d0
22598
22599         ELSE IF ((isel.eq.2)) THEN
22600
22601 !c! Same charge-charge interaction ( +/+ or -/- )
22602         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22603           Qi=Qi*2
22604           Qij=Qij*2
22605          endif
22606         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22607           Qj=Qj*2
22608           Qij=Qij*2
22609          endif
22610
22611          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
22612          eheadtail = ECL + Egb + Epol + Fisocav + Elj
22613 !           eheadtail = 0.0d0
22614
22615 !          ELSE IF ((isel.eq.2.and.  &
22616 !               iabs(Qi).eq.1).and. &
22617 !               nstate(itypi,itypj).ne.1) THEN
22618 !c! Different charge-charge interaction ( +/- or -/+ )
22619 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22620 !            Qi=Qi*2
22621 !            Qij=Qij*2
22622 !           endif
22623 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22624 !            Qj=Qj*2
22625 !            Qij=Qij*2
22626 !           endif
22627 !
22628 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
22629        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
22630       evdw = evdw  + Fcav + eheadtail
22631 !      if (evdw.gt.1.0d6) then
22632 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22633 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22634 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22635 !      Equad,evdwij+Fcav+eheadtail,evdw
22636 !      endif
22637
22638        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22639       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22640       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22641       Equad,evdwij+Fcav+eheadtail,evdw
22642 !       evdw = evdw  + Fcav  + eheadtail
22643
22644 !        iF (nstate(itypi,itypj).eq.1) THEN
22645       CALL sc_grad_cat
22646 !       END IF
22647 !c!-------------------------------------------------------------------
22648 !c! NAPISY KONCOWE
22649        END DO   ! j
22650        END DO     ! i
22651 !c      write (iout,*) "Number of loop steps in EGB:",ind
22652 !c      energy_dec=.false.
22653 !              print *,"EVDW KURW",evdw,nres
22654 !!!        return
22655    17   continue
22656       do i=ibond_start,ibond_end
22657
22658 !        print *,"I am in EVDW",i
22659       itypi=10 ! the peptide group parameters are for glicine
22660
22661 !        if (i.ne.47) cycle
22662       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
22663       itypi1=iabs(itype(i+1,1))
22664       xi=(c(1,i)+c(1,i+1))/2.0
22665       yi=(c(2,i)+c(2,i+1))/2.0
22666       zi=(c(3,i)+c(3,i+1))/2.0
22667         call to_box(xi,yi,zi)
22668       dxi=dc_norm(1,i)
22669       dyi=dc_norm(2,i)
22670       dzi=dc_norm(3,i)
22671       dsci_inv=vbld_inv(i+1)/2.0
22672        do j=itmp+1,itmp+nres_molec(5)
22673
22674 ! Calculate SC interaction energy.
22675           itypj=iabs(itype(j,5))
22676           if ((itypj.eq.ntyp1)) cycle
22677            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22678
22679           dscj_inv=0.0
22680          xj=c(1,j)
22681          yj=c(2,j)
22682          zj=c(3,j)
22683         call to_box(xj,yj,zj)
22684       xj=boxshift(xj-xi,boxxsize)
22685       yj=boxshift(yj-yi,boxysize)
22686       zj=boxshift(zj-zi,boxzsize)
22687
22688         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22689
22690         dxj = 0.0d0! dc_norm( 1, nres+j )
22691         dyj = 0.0d0!dc_norm( 2, nres+j )
22692         dzj = 0.0d0! dc_norm( 3, nres+j )
22693
22694         itypi = 10
22695         itypj = itype(j,5)
22696 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22697 ! sampling performed with amber package
22698 !          alf1   = 0.0d0
22699 !          alf2   = 0.0d0
22700 !          alf12  = 0.0d0
22701 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22702         chi1 = chi1cat(itypi,itypj)
22703         chis1 = chis1cat(itypi,itypj)
22704         chip1 = chipp1cat(itypi,itypj)
22705 !          chi1=0.0d0
22706 !          chis1=0.0d0
22707 !          chip1=0.0d0
22708         chi2=0.0
22709         chip2=0.0
22710         chis2=0.0
22711 !          chis2 = chis(itypj,itypi)
22712         chis12 = chis1 * chis2
22713         sig1 = sigmap1cat(itypi,itypj)
22714 !          sig2 = sigmap2(itypi,itypj)
22715 ! alpha factors from Fcav/Gcav
22716         b1cav = alphasurcat(1,itypi,itypj)
22717         b2cav = alphasurcat(2,itypi,itypj)
22718         b3cav = alphasurcat(3,itypi,itypj)
22719         b4cav = alphasurcat(4,itypi,itypj)
22720
22721 ! used to determine whether we want to do quadrupole calculations
22722        eps_in = epsintabcat(itypi,itypj)
22723        if (eps_in.eq.0.0) eps_in=1.0
22724
22725        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22726 !       Rtail = 0.0d0
22727
22728        DO k = 1, 3
22729       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
22730       ctail(k,2)=c(k,j)
22731        END DO
22732       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
22733       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
22734 !c! tail distances will be themselves usefull elswhere
22735 !c1 (in Gcav, for example)
22736        do k=1,3
22737        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
22738        enddo
22739
22740 !c! tail distances will be themselves usefull elswhere
22741 !c1 (in Gcav, for example)
22742        Rtail = dsqrt( &
22743         (Rtail_distance(1)*Rtail_distance(1)) &
22744       + (Rtail_distance(2)*Rtail_distance(2)) &
22745       + (Rtail_distance(3)*Rtail_distance(3)))
22746 ! tail location and distance calculations
22747 ! dhead1
22748        d1 = dheadcat(1, 1, itypi, itypj)
22749 !       print *,"d1",d1
22750 !       d1=0.0d0
22751 !       d2 = dhead(2, 1, itypi, itypj)
22752        DO k = 1,3
22753 ! location of polar head is computed by taking hydrophobic centre
22754 ! and moving by a d1 * dc_norm vector
22755 ! see unres publications for very informative images
22756       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
22757       chead(k,2) = c(k, j)
22758        ENDDO
22759 ! distance
22760 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22761 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22762       call to_box(chead(1,1),chead(2,1),chead(3,1))
22763       call to_box(chead(1,2),chead(2,2),chead(3,2))
22764
22765 ! distance
22766 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22767 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22768       do k=1,3
22769       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
22770        END DO
22771
22772 ! pitagoras (root of sum of squares)
22773        Rhead = dsqrt( &
22774         (Rhead_distance(1)*Rhead_distance(1)) &
22775       + (Rhead_distance(2)*Rhead_distance(2)) &
22776       + (Rhead_distance(3)*Rhead_distance(3)))
22777 !-------------------------------------------------------------------
22778 ! zero everything that should be zero'ed
22779        evdwij = 0.0d0
22780        ECL = 0.0d0
22781        Elj = 0.0d0
22782        Equad = 0.0d0
22783        Epol = 0.0d0
22784        Fcav=0.0d0
22785        eheadtail = 0.0d0
22786        dGCLdOM1 = 0.0d0
22787        dGCLdOM2 = 0.0d0
22788        dGCLdOM12 = 0.0d0
22789        dPOLdOM1 = 0.0d0
22790        dPOLdOM2 = 0.0d0
22791         Fcav = 0.0d0
22792         dFdR = 0.0d0
22793         dCAVdOM1  = 0.0d0
22794         dCAVdOM2  = 0.0d0
22795         dCAVdOM12 = 0.0d0
22796         dscj_inv = vbld_inv(j+nres)
22797 !          print *,i,j,dscj_inv,dsci_inv
22798 ! rij holds 1/(distance of Calpha atoms)
22799         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22800         rij  = dsqrt(rrij)
22801         CALL sc_angular
22802 ! this should be in elgrad_init but om's are calculated by sc_angular
22803 ! which in turn is used by older potentials
22804 ! om = omega, sqom = om^2
22805         sqom1  = om1 * om1
22806         sqom2  = om2 * om2
22807         sqom12 = om12 * om12
22808
22809 ! now we calculate EGB - Gey-Berne
22810 ! It will be summed up in evdwij and saved in evdw
22811         sigsq     = 1.0D0  / sigsq
22812         sig       = sig0ij * dsqrt(sigsq)
22813 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22814         rij_shift = Rtail - sig + sig0ij
22815         IF (rij_shift.le.0.0D0) THEN
22816          evdw = 1.0D20
22817 !      if (evdw.gt.1.0d6) then
22818 !      write (*,'(2(1x,a3,i3),6f6.2)') &
22819 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22820 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
22821 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22822 !      Equad,evdwij+Fcav+eheadtail,evdw
22823 !      endif
22824          RETURN
22825         END IF
22826         sigder = -sig * sigsq
22827         rij_shift = 1.0D0 / rij_shift
22828         fac       = rij_shift**expon
22829         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22830 !          print *,"ADAM",aa_aq(itypi,itypj)
22831
22832 !          c1        = 0.0d0
22833         c2        = fac  * bb_aq_cat(itypi,itypj)
22834 !          c2        = 0.0d0
22835         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22836         eps2der   = eps3rt * evdwij
22837         eps3der   = eps2rt * evdwij
22838 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22839         evdwij    = eps2rt * eps3rt * evdwij
22840 !#ifdef TSCSC
22841 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22842 !           evdw_p = evdw_p + evdwij
22843 !          ELSE
22844 !           evdw_m = evdw_m + evdwij
22845 !          END IF
22846 !#else
22847         evdw = evdw  &
22848             + evdwij
22849 !#endif
22850         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22851         fac    = -expon * (c1 + evdwij) * rij_shift
22852         sigder = fac * sigder
22853 ! Calculate distance derivative
22854         gg(1) =  fac
22855         gg(2) =  fac
22856         gg(3) =  fac
22857
22858         fac = chis1 * sqom1 + chis2 * sqom2 &
22859         - 2.0d0 * chis12 * om1 * om2 * om12
22860
22861         pom = 1.0d0 - chis1 * chis2 * sqom12
22862 !          print *,"TUT2",fac,chis1,sqom1,pom
22863         Lambf = (1.0d0 - (fac / pom))
22864         Lambf = dsqrt(Lambf)
22865         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22866         Chif = Rtail * sparrow
22867         ChiLambf = Chif * Lambf
22868         eagle = dsqrt(ChiLambf)
22869         bat = ChiLambf ** 11.0d0
22870         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22871         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22872         botsq = bot * bot
22873         Fcav = top / bot
22874
22875        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22876        dbot = 12.0d0 * b4cav * bat * Lambf
22877        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22878
22879         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22880         dbot = 12.0d0 * b4cav * bat * Chif
22881         eagle = Lambf * pom
22882         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22883         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22884         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22885             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22886
22887         dFdL = ((dtop * bot - top * dbot) / botsq)
22888         dCAVdOM1  = dFdL * ( dFdOM1 )
22889         dCAVdOM2  = dFdL * ( dFdOM2 )
22890         dCAVdOM12 = dFdL * ( dFdOM12 )
22891
22892        DO k= 1, 3
22893       ertail(k) = Rtail_distance(k)/Rtail
22894        END DO
22895        erdxi = scalar( ertail(1), dC_norm(1,i) )
22896        erdxj = scalar( ertail(1), dC_norm(1,j) )
22897        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
22898        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22899        DO k = 1, 3
22900       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
22901 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
22902 !                  - (( dFdR + gg(k) ) * pom)
22903       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22904 !        gvdwx(k,j) = gvdwx(k,j)   &
22905 !                  + (( dFdR + gg(k) ) * pom)
22906       gradpepcat(k,i) = gradpepcat(k,i)  &
22907               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22908       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
22909               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22910
22911       gradpepcat(k,j) = gradpepcat(k,j) &
22912               + (( dFdR + gg(k) ) * ertail(k))
22913       gg(k) = 0.0d0
22914        ENDDO
22915 !c! Compute head-head and head-tail energies for each state
22916         isel = 3
22917 !c! Dipole-charge interactions
22918         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22919           Qi=Qi*2
22920           Qij=Qij*2
22921          endif
22922         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22923           Qj=Qj*2
22924           Qij=Qij*2
22925          endif
22926          CALL edq_cat_pep(ecl, elj, epol)
22927          eheadtail = ECL + elj + epol
22928 !          print *,"i,",i,eheadtail
22929 !           eheadtail = 0.0d0
22930
22931       evdw = evdw  + Fcav + eheadtail
22932 !      if (evdw.gt.1.0d6) then
22933 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22934 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22935 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22936 !      Equad,evdwij+Fcav+eheadtail,evdw
22937 !      endif
22938        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22939       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22940       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22941       Equad,evdwij+Fcav+eheadtail,evdw
22942 !       evdw = evdw  + Fcav  + eheadtail
22943
22944 !        iF (nstate(itypi,itypj).eq.1) THEN
22945       CALL sc_grad_cat_pep
22946 !       END IF
22947 !c!-------------------------------------------------------------------
22948 !c! NAPISY KONCOWE
22949        END DO   ! j
22950        END DO     ! i
22951 !c      write (iout,*) "Number of loop steps in EGB:",ind
22952 !c      energy_dec=.false.
22953 !              print *,"EVDW KURW",evdw,nres
22954
22955
22956       return
22957       end subroutine ecats_prot_amber
22958
22959 !---------------------------------------------------------------------------
22960 ! old for Ca2+
22961        subroutine ecat_prot(ecation_prot)
22962 !      use calc_data
22963 !      use comm_momo
22964        integer i,j,k,subchap,itmp,inum
22965       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22966       r7,r4,ecationcation
22967       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22968       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22969       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22970       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22971       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22972       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22973       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22974       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22975       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22976       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22977       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22978       ndiv,ndivi
22979       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22980       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22981       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22982       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22983       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22984       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22985       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22986       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22987       dEvan1Cat
22988       real(kind=8),dimension(6) :: vcatprm
22989       ecation_prot=0.0d0
22990 ! first lets calculate interaction with peptide groups
22991       if (nres_molec(5).eq.0) return
22992       itmp=0
22993       do i=1,4
22994       itmp=itmp+nres_molec(i)
22995       enddo
22996 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22997       do i=ibond_start,ibond_end
22998 !         cycle
22999        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23000       xi=0.5d0*(c(1,i)+c(1,i+1))
23001       yi=0.5d0*(c(2,i)+c(2,i+1))
23002       zi=0.5d0*(c(3,i)+c(3,i+1))
23003         call to_box(xi,yi,zi)
23004
23005        do j=itmp+1,itmp+nres_molec(5)
23006 !           print *,"WTF",itmp,j,i
23007 ! all parameters were for Ca2+ to approximate single charge divide by two
23008        ndiv=1.0
23009        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23010        wconst=78*ndiv
23011       wdip =1.092777950857032D2
23012       wdip=wdip/wconst
23013       wmodquad=-2.174122713004870D4
23014       wmodquad=wmodquad/wconst
23015       wquad1 = 3.901232068562804D1
23016       wquad1=wquad1/wconst
23017       wquad2 = 3
23018       wquad2=wquad2/wconst
23019       wvan1 = 0.1
23020       wvan2 = 6
23021 !        itmp=0
23022
23023          xj=c(1,j)
23024          yj=c(2,j)
23025          zj=c(3,j)
23026         call to_box(xj,yj,zj)
23027       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23028 !       enddo
23029 !       enddo
23030        rcpm = sqrt(xj**2+yj**2+zj**2)
23031        drcp_norm(1)=xj/rcpm
23032        drcp_norm(2)=yj/rcpm
23033        drcp_norm(3)=zj/rcpm
23034        dcmag=0.0
23035        do k=1,3
23036        dcmag=dcmag+dc(k,i)**2
23037        enddo
23038        dcmag=dsqrt(dcmag)
23039        do k=1,3
23040        myd_norm(k)=dc(k,i)/dcmag
23041        enddo
23042       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23043       drcp_norm(3)*myd_norm(3)
23044       rsecp = rcpm**2
23045       Ir = 1.0d0/rcpm
23046       Irsecp = 1.0d0/rsecp
23047       Irthrp = Irsecp/rcpm
23048       Irfourp = Irthrp/rcpm
23049       Irfiftp = Irfourp/rcpm
23050       Irsistp=Irfiftp/rcpm
23051       Irseven=Irsistp/rcpm
23052       Irtwelv=Irsistp*Irsistp
23053       Irthir=Irtwelv/rcpm
23054       sin2thet = (1-costhet*costhet)
23055       sinthet=sqrt(sin2thet)
23056       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23057            *sin2thet
23058       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23059            2*wvan2**6*Irsistp)
23060       ecation_prot = ecation_prot+E1+E2
23061 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23062       dE1dr = -2*costhet*wdip*Irthrp-&
23063        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23064       dE2dr = 3*wquad1*wquad2*Irfourp-     &
23065         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23066       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23067       do k=1,3
23068         drdpep(k) = -drcp_norm(k)
23069         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23070         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23071         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23072         dEddci(k) = dEdcos*dcosddci(k)
23073       enddo
23074       do k=1,3
23075       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23076       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23077       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23078       enddo
23079        enddo ! j
23080        enddo ! i
23081 !------------------------------------------sidechains
23082 !        do i=1,nres_molec(1)
23083       do i=ibond_start,ibond_end
23084        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23085 !         cycle
23086 !        print *,i,ecation_prot
23087       xi=(c(1,i+nres))
23088       yi=(c(2,i+nres))
23089       zi=(c(3,i+nres))
23090                 call to_box(xi,yi,zi)
23091         do k=1,3
23092           cm1(k)=dc(k,i+nres)
23093         enddo
23094          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23095        do j=itmp+1,itmp+nres_molec(5)
23096        ndiv=1.0
23097        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23098
23099          xj=c(1,j)
23100          yj=c(2,j)
23101          zj=c(3,j)
23102         call to_box(xj,yj,zj)
23103       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23104 !       enddo
23105 !       enddo
23106 ! 15- Glu 16-Asp
23107        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23108        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23109        (itype(i,1).eq.25))) then
23110           if(itype(i,1).eq.16) then
23111           inum=1
23112           else
23113           inum=2
23114           endif
23115           do k=1,6
23116           vcatprm(k)=catprm(k,inum)
23117           enddo
23118           dASGL=catprm(7,inum)
23119 !             do k=1,3
23120 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23121             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23122             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23123             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23124
23125 !                valpha(k)=c(k,i)
23126 !                vcat(k)=c(k,j)
23127             if (subchap.eq.1) then
23128              vcat(1)=xj_temp
23129              vcat(2)=yj_temp
23130              vcat(3)=zj_temp
23131              else
23132             vcat(1)=xj_safe
23133             vcat(2)=yj_safe
23134             vcat(3)=zj_safe
23135              endif
23136             valpha(1)=xi-c(1,i+nres)+c(1,i)
23137             valpha(2)=yi-c(2,i+nres)+c(2,i)
23138             valpha(3)=zi-c(3,i+nres)+c(3,i)
23139
23140 !              enddo
23141       do k=1,3
23142         dx(k) = vcat(k)-vcm(k)
23143       enddo
23144       do k=1,3
23145         v1(k)=(vcm(k)-valpha(k))
23146         v2(k)=(vcat(k)-valpha(k))
23147       enddo
23148       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23149       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23150       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23151
23152 !  The weights of the energy function calculated from
23153 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23154         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23155           ndivi=0.5
23156         else
23157           ndivi=1.0
23158         endif
23159        ndiv=1.0
23160        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23161
23162       wh2o=78*ndivi*ndiv
23163       wc = vcatprm(1)
23164       wc=wc/wh2o
23165       wdip =vcatprm(2)
23166       wdip=wdip/wh2o
23167       wquad1 =vcatprm(3)
23168       wquad1=wquad1/wh2o
23169       wquad2 = vcatprm(4)
23170       wquad2=wquad2/wh2o
23171       wquad2p = 1.0d0-wquad2
23172       wvan1 = vcatprm(5)
23173       wvan2 =vcatprm(6)
23174       opt = dx(1)**2+dx(2)**2
23175       rsecp = opt+dx(3)**2
23176       rs = sqrt(rsecp)
23177       rthrp = rsecp*rs
23178       rfourp = rthrp*rs
23179       rsixp = rfourp*rsecp
23180       reight=rsixp*rsecp
23181       Ir = 1.0d0/rs
23182       Irsecp = 1.0d0/rsecp
23183       Irthrp = Irsecp/rs
23184       Irfourp = Irthrp/rs
23185       Irsixp = 1.0d0/rsixp
23186       Ireight=1.0d0/reight
23187       Irtw=Irsixp*Irsixp
23188       Irthir=Irtw/rs
23189       Irfourt=Irthir/rs
23190       opt1 = (4*rs*dx(3)*wdip)
23191       opt2 = 6*rsecp*wquad1*opt
23192       opt3 = wquad1*wquad2p*Irsixp
23193       opt4 = (wvan1*wvan2**12)
23194       opt5 = opt4*12*Irfourt
23195       opt6 = 2*wvan1*wvan2**6
23196       opt7 = 6*opt6*Ireight
23197       opt8 = wdip/v1m
23198       opt10 = wdip/v2m
23199       opt11 = (rsecp*v2m)**2
23200       opt12 = (rsecp*v1m)**2
23201       opt14 = (v1m*v2m*rsecp)**2
23202       opt15 = -wquad1/v2m**2
23203       opt16 = (rthrp*(v1m*v2m)**2)**2
23204       opt17 = (v1m**2*rthrp)**2
23205       opt18 = -wquad1/rthrp
23206       opt19 = (v1m**2*v2m**2)**2
23207       Ec = wc*Ir
23208       do k=1,3
23209         dEcCat(k) = -(dx(k)*wc)*Irthrp
23210         dEcCm(k)=(dx(k)*wc)*Irthrp
23211         dEcCalp(k)=0.0d0
23212       enddo
23213       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23214       do k=1,3
23215         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23216                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23217         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23218                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23219         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23220                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23221                   *v1dpv2)/opt14
23222       enddo
23223       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23224       do k=1,3
23225         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23226                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23227                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23228         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23229                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23230                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23231         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23232                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23233                   v1dpv2**2)/opt19
23234       enddo
23235       Equad2=wquad1*wquad2p*Irthrp
23236       do k=1,3
23237         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23238         dEquad2Cm(k)=3*dx(k)*rs*opt3
23239         dEquad2Calp(k)=0.0d0
23240       enddo
23241       Evan1=opt4*Irtw
23242       do k=1,3
23243         dEvan1Cat(k)=-dx(k)*opt5
23244         dEvan1Cm(k)=dx(k)*opt5
23245         dEvan1Calp(k)=0.0d0
23246       enddo
23247       Evan2=-opt6*Irsixp
23248       do k=1,3
23249         dEvan2Cat(k)=dx(k)*opt7
23250         dEvan2Cm(k)=-dx(k)*opt7
23251         dEvan2Calp(k)=0.0d0
23252       enddo
23253       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23254 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23255
23256       do k=1,3
23257         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23258                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23259 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23260         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23261                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23262         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23263                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23264       enddo
23265           dscmag = 0.0d0
23266           do k=1,3
23267             dscvec(k) = dc(k,i+nres)
23268             dscmag = dscmag+dscvec(k)*dscvec(k)
23269           enddo
23270           dscmag3 = dscmag
23271           dscmag = sqrt(dscmag)
23272           dscmag3 = dscmag3*dscmag
23273           constA = 1.0d0+dASGL/dscmag
23274           constB = 0.0d0
23275           do k=1,3
23276             constB = constB+dscvec(k)*dEtotalCm(k)
23277           enddo
23278           constB = constB*dASGL/dscmag3
23279           do k=1,3
23280             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23281             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23282              constA*dEtotalCm(k)-constB*dscvec(k)
23283 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23284             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23285             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23286            enddo
23287       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23288          if(itype(i,1).eq.14) then
23289           inum=3
23290           else
23291           inum=4
23292           endif
23293           do k=1,6
23294           vcatprm(k)=catprm(k,inum)
23295           enddo
23296           dASGL=catprm(7,inum)
23297 !             do k=1,3
23298 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23299 !                valpha(k)=c(k,i)
23300 !                vcat(k)=c(k,j)
23301 !              enddo
23302             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23303             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23304             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23305             if (subchap.eq.1) then
23306              vcat(1)=xj_temp
23307              vcat(2)=yj_temp
23308              vcat(3)=zj_temp
23309              else
23310             vcat(1)=xj_safe
23311             vcat(2)=yj_safe
23312             vcat(3)=zj_safe
23313             endif
23314             valpha(1)=xi-c(1,i+nres)+c(1,i)
23315             valpha(2)=yi-c(2,i+nres)+c(2,i)
23316             valpha(3)=zi-c(3,i+nres)+c(3,i)
23317
23318
23319       do k=1,3
23320         dx(k) = vcat(k)-vcm(k)
23321       enddo
23322       do k=1,3
23323         v1(k)=(vcm(k)-valpha(k))
23324         v2(k)=(vcat(k)-valpha(k))
23325       enddo
23326       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23327       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23328       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23329 !  The weights of the energy function calculated from
23330 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23331        ndiv=1.0
23332        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23333
23334       wh2o=78*ndiv
23335       wdip =vcatprm(2)
23336       wdip=wdip/wh2o
23337       wquad1 =vcatprm(3)
23338       wquad1=wquad1/wh2o
23339       wquad2 = vcatprm(4)
23340       wquad2=wquad2/wh2o
23341       wquad2p = 1-wquad2
23342       wvan1 = vcatprm(5)
23343       wvan2 =vcatprm(6)
23344       opt = dx(1)**2+dx(2)**2
23345       rsecp = opt+dx(3)**2
23346       rs = sqrt(rsecp)
23347       rthrp = rsecp*rs
23348       rfourp = rthrp*rs
23349       rsixp = rfourp*rsecp
23350       reight=rsixp*rsecp
23351       Ir = 1.0d0/rs
23352       Irsecp = 1/rsecp
23353       Irthrp = Irsecp/rs
23354       Irfourp = Irthrp/rs
23355       Irsixp = 1/rsixp
23356       Ireight=1/reight
23357       Irtw=Irsixp*Irsixp
23358       Irthir=Irtw/rs
23359       Irfourt=Irthir/rs
23360       opt1 = (4*rs*dx(3)*wdip)
23361       opt2 = 6*rsecp*wquad1*opt
23362       opt3 = wquad1*wquad2p*Irsixp
23363       opt4 = (wvan1*wvan2**12)
23364       opt5 = opt4*12*Irfourt
23365       opt6 = 2*wvan1*wvan2**6
23366       opt7 = 6*opt6*Ireight
23367       opt8 = wdip/v1m
23368       opt10 = wdip/v2m
23369       opt11 = (rsecp*v2m)**2
23370       opt12 = (rsecp*v1m)**2
23371       opt14 = (v1m*v2m*rsecp)**2
23372       opt15 = -wquad1/v2m**2
23373       opt16 = (rthrp*(v1m*v2m)**2)**2
23374       opt17 = (v1m**2*rthrp)**2
23375       opt18 = -wquad1/rthrp
23376       opt19 = (v1m**2*v2m**2)**2
23377       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23378       do k=1,3
23379         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23380                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23381        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23382                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23383         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23384                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23385                   *v1dpv2)/opt14
23386       enddo
23387       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23388       do k=1,3
23389         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23390                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23391                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23392         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23393                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23394                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23395         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23396                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23397                   v1dpv2**2)/opt19
23398       enddo
23399       Equad2=wquad1*wquad2p*Irthrp
23400       do k=1,3
23401         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23402         dEquad2Cm(k)=3*dx(k)*rs*opt3
23403         dEquad2Calp(k)=0.0d0
23404       enddo
23405       Evan1=opt4*Irtw
23406       do k=1,3
23407         dEvan1Cat(k)=-dx(k)*opt5
23408         dEvan1Cm(k)=dx(k)*opt5
23409         dEvan1Calp(k)=0.0d0
23410       enddo
23411       Evan2=-opt6*Irsixp
23412       do k=1,3
23413         dEvan2Cat(k)=dx(k)*opt7
23414         dEvan2Cm(k)=-dx(k)*opt7
23415         dEvan2Calp(k)=0.0d0
23416       enddo
23417        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23418       do k=1,3
23419         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23420                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23421         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23422                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23423         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23424                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23425       enddo
23426           dscmag = 0.0d0
23427           do k=1,3
23428             dscvec(k) = c(k,i+nres)-c(k,i)
23429 ! TU SPRAWDZ???
23430 !              dscvec(1) = xj
23431 !              dscvec(2) = yj
23432 !              dscvec(3) = zj
23433
23434             dscmag = dscmag+dscvec(k)*dscvec(k)
23435           enddo
23436           dscmag3 = dscmag
23437           dscmag = sqrt(dscmag)
23438           dscmag3 = dscmag3*dscmag
23439           constA = 1+dASGL/dscmag
23440           constB = 0.0d0
23441           do k=1,3
23442             constB = constB+dscvec(k)*dEtotalCm(k)
23443           enddo
23444           constB = constB*dASGL/dscmag3
23445           do k=1,3
23446             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23447             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23448              constA*dEtotalCm(k)-constB*dscvec(k)
23449             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23450             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23451            enddo
23452          else
23453           rcal = 0.0d0
23454           do k=1,3
23455 !              r(k) = c(k,j)-c(k,i+nres)
23456             r(1) = xj
23457             r(2) = yj
23458             r(3) = zj
23459             rcal = rcal+r(k)*r(k)
23460           enddo
23461           ract=sqrt(rcal)
23462           rocal=1.5
23463           epscalc=0.2
23464           r0p=0.5*(rocal+sig0(itype(i,1)))
23465           r06 = r0p**6
23466           r012 = r06*r06
23467           Evan1=epscalc*(r012/rcal**6)
23468           Evan2=epscalc*2*(r06/rcal**3)
23469           r4 = rcal**4
23470           r7 = rcal**7
23471           do k=1,3
23472             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23473             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23474           enddo
23475           do k=1,3
23476             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23477           enddo
23478              ecation_prot = ecation_prot+ Evan1+Evan2
23479           do  k=1,3
23480              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23481              dEtotalCm(k)
23482             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23483             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23484            enddo
23485        endif ! 13-16 residues
23486        enddo !j
23487        enddo !i
23488        return
23489        end subroutine ecat_prot
23490
23491 !----------------------------------------------------------------------------
23492 !---------------------------------------------------------------------------
23493        subroutine ecat_nucl(ecation_nucl)
23494        integer i,j,k,subchap,itmp,inum,itypi,itypj
23495        real(kind=8) :: xi,yi,zi,xj,yj,zj
23496        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23497        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
23498        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
23499        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
23500        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
23501        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
23502        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
23503        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
23504        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
23505        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
23506        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
23507        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
23508        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
23509        dEcavdCm
23510        real(kind=8),dimension(14) :: vcatnuclprm
23511        ecation_nucl=0.0d0
23512        if (nres_molec(5).eq.0) return
23513        itmp=0
23514        do i=1,4
23515           itmp=itmp+nres_molec(i)
23516        enddo
23517        do i=iatsc_s_nucl,iatsc_e_nucl
23518           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
23519           xi=(c(1,i+nres))
23520           yi=(c(2,i+nres))
23521           zi=(c(3,i+nres))
23522       call to_box(xi,yi,zi)
23523       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23524           do k=1,3
23525              cm1(k)=dc(k,i+nres)
23526           enddo
23527           do j=itmp+1,itmp+nres_molec(5)
23528              xj=c(1,j)
23529              yj=c(2,j)
23530              zj=c(3,j)
23531       call to_box(xj,yj,zj)
23532 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23533 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23534 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23535 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23536 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23537 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23538       xj=boxshift(xj-xi,boxxsize)
23539       yj=boxshift(yj-yi,boxysize)
23540       zj=boxshift(zj-zi,boxzsize)
23541 !       write(iout,*) 'after shift', xj,yj,zj
23542              dist_init=xj**2+yj**2+zj**2
23543
23544              itypi=itype(i,2)
23545              itypj=itype(j,5)
23546              do k=1,13
23547                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
23548              enddo
23549              do k=1,3
23550                 vcm(k)=c(k,i+nres)
23551                 vsug(k)=c(k,i)
23552                 vcat(k)=c(k,j)
23553              enddo
23554              do k=1,3
23555                 dx(k) = vcat(k)-vcm(k)
23556              enddo
23557              do k=1,3
23558                 v1(k)=dc(k,i+nres)
23559                 v2(k)=(vcat(k)-vsug(k))
23560              enddo
23561              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23562              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
23563 !  The weights of the energy function calculated from
23564 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
23565              wh2o=78
23566              wdip1 = vcatnuclprm(1)
23567              wdip1 = wdip1/wh2o                     !w1
23568              wdip2 = vcatnuclprm(2)
23569              wdip2 = wdip2/wh2o                     !w2
23570              wvan1 = vcatnuclprm(3)
23571              wvan2 = vcatnuclprm(4)                 !pis1
23572              wgbsig = vcatnuclprm(5)                !sigma0
23573              wgbeps = vcatnuclprm(6)                !epsi0
23574              wgbchi = vcatnuclprm(7)                !chi1
23575              wgbchip = vcatnuclprm(8)               !chip1
23576              wcavsig = vcatnuclprm(9)               !sig
23577              wcav1 = vcatnuclprm(10)                !b1
23578              wcav2 = vcatnuclprm(11)                !b2
23579              wcav3 = vcatnuclprm(12)                !b3
23580              wcav4 = vcatnuclprm(13)                !b4
23581              wcavchi = vcatnuclprm(14)              !chis1
23582              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
23583              invrcs6 = 1/rcs2**3
23584              invrcs8 = invrcs6/rcs2
23585              invrcs12 = invrcs6**2
23586              invrcs14 = invrcs12/rcs2
23587              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
23588              rcb = sqrt(rcb2)
23589              invrcb = 1/rcb
23590              invrcb2 = invrcb**2
23591              invrcb4 = invrcb2**2
23592              invrcb6 = invrcb4*invrcb2
23593              cosinus = v1dpdx/(v1m*rcb)
23594              cos2 = cosinus**2
23595              dcosdcatconst = invrcb2/v1m
23596              dcosdcalpconst = invrcb/v1m**2
23597              dcosdcmconst = invrcb2/v1m**2
23598              do k=1,3
23599                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
23600                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
23601                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
23602                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
23603              enddo
23604              rcav = rcb/wcavsig
23605              rcav11 = rcav**11
23606              rcav12 = rcav11*rcav
23607              constcav1 = 1-wcavchi*cos2
23608              constcav2 = sqrt(constcav1)
23609              constgb1 = 1/sqrt(1-wgbchi*cos2)
23610              constgb2 = wgbeps*(1-wgbchip*cos2)**2
23611              constdvan1 = 12*wvan1*wvan2**12*invrcs14
23612              constdvan2 = 6*wvan1*wvan2**6*invrcs8
23613 !----------------------------------------------------------------------------
23614 !Gay-Berne term
23615 !---------------------------------------------------------------------------
23616              sgb = 1/(1-constgb1+(rcb/wgbsig))
23617              sgb6 = sgb**6
23618              sgb7 = sgb6*sgb
23619              sgb12 = sgb6**2
23620              sgb13 = sgb12*sgb
23621              Egb = constgb2*(sgb12-sgb6)
23622              do k=1,3
23623                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23624                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23625      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
23626                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23627                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23628      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
23629                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
23630                                *(12*sgb13-6*sgb7) &
23631      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
23632              enddo
23633 !----------------------------------------------------------------------------
23634 !cavity term
23635 !---------------------------------------------------------------------------
23636              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
23637              cavdenom = 1+wcav4*rcav12*constcav1**6
23638              Ecav = wcav1*cavnum/cavdenom
23639              invcavdenom2 = 1/cavdenom**2
23640              dcavnumdcos = -wcavchi*cosinus/constcav2 &
23641                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
23642              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
23643              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
23644              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
23645              do k=1,3
23646                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23647      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23648                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23649      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23650                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23651                              *dcosdcalp(k)*wcav1*invcavdenom2
23652              enddo
23653 !----------------------------------------------------------------------------
23654 !van der Waals and dipole-charge interaction energy
23655 !---------------------------------------------------------------------------
23656              Evan1 = wvan1*wvan2**12*invrcs12
23657              do k=1,3
23658                 dEvan1Cat(k) = -v2(k)*constdvan1
23659                 dEvan1Cm(k) = 0.0d0
23660                 dEvan1Calp(k) = v2(k)*constdvan1
23661              enddo
23662              Evan2 = -wvan1*wvan2**6*invrcs6
23663              do k=1,3
23664                 dEvan2Cat(k) = v2(k)*constdvan2
23665                 dEvan2Cm(k) = 0.0d0
23666                 dEvan2Calp(k) = -v2(k)*constdvan2
23667              enddo
23668              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
23669              do k=1,3
23670                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
23671                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23672                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23673                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
23674                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23675                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23676                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
23677                                   +2*wdip2*cosinus*invrcb4)
23678              enddo
23679              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
23680          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
23681              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
23682              do k=1,3
23683                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
23684                                              +dEgbdCat(k)+dEdipCat(k)
23685                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
23686                                            +dEgbdCm(k)+dEdipCm(k)
23687                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
23688                                              +dEdipCalp(k)+dEvan2Calp(k)
23689              enddo
23690              do k=1,3
23691                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23692                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
23693                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
23694                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
23695              enddo
23696           enddo !j
23697        enddo !i
23698        return
23699        end subroutine ecat_nucl
23700
23701 !-----------------------------------------------------------------------------
23702 !-----------------------------------------------------------------------------
23703       subroutine eprot_sc_base(escbase)
23704       use calc_data
23705 !      implicit real*8 (a-h,o-z)
23706 !      include 'DIMENSIONS'
23707 !      include 'COMMON.GEO'
23708 !      include 'COMMON.VAR'
23709 !      include 'COMMON.LOCAL'
23710 !      include 'COMMON.CHAIN'
23711 !      include 'COMMON.DERIV'
23712 !      include 'COMMON.NAMES'
23713 !      include 'COMMON.INTERACT'
23714 !      include 'COMMON.IOUNITS'
23715 !      include 'COMMON.CALC'
23716 !      include 'COMMON.CONTROL'
23717 !      include 'COMMON.SBRIDGE'
23718       logical :: lprn
23719 !el local variables
23720       integer :: iint,itypi,itypi1,itypj,subchap
23721       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23722       real(kind=8) :: evdw,sig0ij
23723       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23724                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23725                 sslipi,sslipj,faclip
23726       integer :: ii
23727       real(kind=8) :: fracinbuf
23728        real (kind=8) :: escbase
23729        real (kind=8),dimension(4):: ener
23730        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23731        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23732       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23733       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23734       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23735       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23736       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23737       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23738        real(kind=8),dimension(3,2)::chead,erhead_tail
23739        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23740        integer troll
23741        eps_out=80.0d0
23742        escbase=0.0d0
23743 !       do i=1,nres_molec(1)
23744       do i=ibond_start,ibond_end
23745       if (itype(i,1).eq.ntyp1_molec(1)) cycle
23746       itypi  = itype(i,1)
23747       dxi    = dc_norm(1,nres+i)
23748       dyi    = dc_norm(2,nres+i)
23749       dzi    = dc_norm(3,nres+i)
23750       dsci_inv = vbld_inv(i+nres)
23751       xi=c(1,nres+i)
23752       yi=c(2,nres+i)
23753       zi=c(3,nres+i)
23754       call to_box(xi,yi,zi)
23755       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23756        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23757          itypj= itype(j,2)
23758          if (itype(j,2).eq.ntyp1_molec(2))cycle
23759          xj=c(1,j+nres)
23760          yj=c(2,j+nres)
23761          zj=c(3,j+nres)
23762       call to_box(xj,yj,zj)
23763 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23764 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23765 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23766 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23767 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23768       xj=boxshift(xj-xi,boxxsize)
23769       yj=boxshift(yj-yi,boxysize)
23770       zj=boxshift(zj-zi,boxzsize)
23771
23772         dxj = dc_norm( 1, nres+j )
23773         dyj = dc_norm( 2, nres+j )
23774         dzj = dc_norm( 3, nres+j )
23775 !          print *,i,j,itypi,itypj
23776         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23777         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23778 !          d1i=0.0d0
23779 !          d1j=0.0d0
23780 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23781 ! Gay-berne var's
23782         sig0ij = sigma_scbase( itypi,itypj )
23783         chi1   = chi_scbase( itypi, itypj,1 )
23784         chi2   = chi_scbase( itypi, itypj,2 )
23785 !          chi1=0.0d0
23786 !          chi2=0.0d0
23787         chi12  = chi1 * chi2
23788         chip1  = chipp_scbase( itypi, itypj,1 )
23789         chip2  = chipp_scbase( itypi, itypj,2 )
23790 !          chip1=0.0d0
23791 !          chip2=0.0d0
23792         chip12 = chip1 * chip2
23793 ! not used by momo potential, but needed by sc_angular which is shared
23794 ! by all energy_potential subroutines
23795         alf1   = 0.0d0
23796         alf2   = 0.0d0
23797         alf12  = 0.0d0
23798         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23799 !       a12sq = a12sq * a12sq
23800 ! charge of amino acid itypi is...
23801         chis1 = chis_scbase(itypi,itypj,1)
23802         chis2 = chis_scbase(itypi,itypj,2)
23803         chis12 = chis1 * chis2
23804         sig1 = sigmap1_scbase(itypi,itypj)
23805         sig2 = sigmap2_scbase(itypi,itypj)
23806 !       write (*,*) "sig1 = ", sig1
23807 !       write (*,*) "sig2 = ", sig2
23808 ! alpha factors from Fcav/Gcav
23809         b1 = alphasur_scbase(1,itypi,itypj)
23810 !          b1=0.0d0
23811         b2 = alphasur_scbase(2,itypi,itypj)
23812         b3 = alphasur_scbase(3,itypi,itypj)
23813         b4 = alphasur_scbase(4,itypi,itypj)
23814 ! used to determine whether we want to do quadrupole calculations
23815 ! used by Fgb
23816        eps_in = epsintab_scbase(itypi,itypj)
23817        if (eps_in.eq.0.0) eps_in=1.0
23818        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23819 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23820 !-------------------------------------------------------------------
23821 ! tail location and distance calculations
23822        DO k = 1,3
23823 ! location of polar head is computed by taking hydrophobic centre
23824 ! and moving by a d1 * dc_norm vector
23825 ! see unres publications for very informative images
23826       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23827       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23828 ! distance
23829 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23830 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23831       Rhead_distance(k) = chead(k,2) - chead(k,1)
23832        END DO
23833 ! pitagoras (root of sum of squares)
23834        Rhead = dsqrt( &
23835         (Rhead_distance(1)*Rhead_distance(1)) &
23836       + (Rhead_distance(2)*Rhead_distance(2)) &
23837       + (Rhead_distance(3)*Rhead_distance(3)))
23838 !-------------------------------------------------------------------
23839 ! zero everything that should be zero'ed
23840        evdwij = 0.0d0
23841        ECL = 0.0d0
23842        Elj = 0.0d0
23843        Equad = 0.0d0
23844        Epol = 0.0d0
23845        Fcav=0.0d0
23846        eheadtail = 0.0d0
23847        dGCLdOM1 = 0.0d0
23848        dGCLdOM2 = 0.0d0
23849        dGCLdOM12 = 0.0d0
23850        dPOLdOM1 = 0.0d0
23851        dPOLdOM2 = 0.0d0
23852         Fcav = 0.0d0
23853         dFdR = 0.0d0
23854         dCAVdOM1  = 0.0d0
23855         dCAVdOM2  = 0.0d0
23856         dCAVdOM12 = 0.0d0
23857         dscj_inv = vbld_inv(j+nres)
23858 !          print *,i,j,dscj_inv,dsci_inv
23859 ! rij holds 1/(distance of Calpha atoms)
23860         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23861         rij  = dsqrt(rrij)
23862 !----------------------------
23863         CALL sc_angular
23864 ! this should be in elgrad_init but om's are calculated by sc_angular
23865 ! which in turn is used by older potentials
23866 ! om = omega, sqom = om^2
23867         sqom1  = om1 * om1
23868         sqom2  = om2 * om2
23869         sqom12 = om12 * om12
23870
23871 ! now we calculate EGB - Gey-Berne
23872 ! It will be summed up in evdwij and saved in evdw
23873         sigsq     = 1.0D0  / sigsq
23874         sig       = sig0ij * dsqrt(sigsq)
23875 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23876         rij_shift = 1.0/rij - sig + sig0ij
23877         IF (rij_shift.le.0.0D0) THEN
23878          evdw = 1.0D20
23879          RETURN
23880         END IF
23881         sigder = -sig * sigsq
23882         rij_shift = 1.0D0 / rij_shift
23883         fac       = rij_shift**expon
23884         c1        = fac  * fac * aa_scbase(itypi,itypj)
23885 !          c1        = 0.0d0
23886         c2        = fac  * bb_scbase(itypi,itypj)
23887 !          c2        = 0.0d0
23888         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23889         eps2der   = eps3rt * evdwij
23890         eps3der   = eps2rt * evdwij
23891 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23892         evdwij    = eps2rt * eps3rt * evdwij
23893         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23894         fac    = -expon * (c1 + evdwij) * rij_shift
23895         sigder = fac * sigder
23896 !          fac    = rij * fac
23897 ! Calculate distance derivative
23898         gg(1) =  fac
23899         gg(2) =  fac
23900         gg(3) =  fac
23901 !          if (b2.gt.0.0) then
23902         fac = chis1 * sqom1 + chis2 * sqom2 &
23903         - 2.0d0 * chis12 * om1 * om2 * om12
23904 ! we will use pom later in Gcav, so dont mess with it!
23905         pom = 1.0d0 - chis1 * chis2 * sqom12
23906         Lambf = (1.0d0 - (fac / pom))
23907         Lambf = dsqrt(Lambf)
23908         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23909 !       write (*,*) "sparrow = ", sparrow
23910         Chif = 1.0d0/rij * sparrow
23911         ChiLambf = Chif * Lambf
23912         eagle = dsqrt(ChiLambf)
23913         bat = ChiLambf ** 11.0d0
23914         top = b1 * ( eagle + b2 * ChiLambf - b3 )
23915         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23916         botsq = bot * bot
23917         Fcav = top / bot
23918 !          print *,i,j,Fcav
23919         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23920         dbot = 12.0d0 * b4 * bat * Lambf
23921         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23922 !       dFdR = 0.0d0
23923 !      write (*,*) "dFcav/dR = ", dFdR
23924         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23925         dbot = 12.0d0 * b4 * bat * Chif
23926         eagle = Lambf * pom
23927         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23928         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23929         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23930             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23931
23932         dFdL = ((dtop * bot - top * dbot) / botsq)
23933 !       dFdL = 0.0d0
23934         dCAVdOM1  = dFdL * ( dFdOM1 )
23935         dCAVdOM2  = dFdL * ( dFdOM2 )
23936         dCAVdOM12 = dFdL * ( dFdOM12 )
23937
23938         ertail(1) = xj*rij
23939         ertail(2) = yj*rij
23940         ertail(3) = zj*rij
23941 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23942 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23943 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23944 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23945 !           print *,"EOMY",eom1,eom2,eom12
23946 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23947 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23948 ! here dtail=0.0
23949 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23950 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23951        DO k = 1, 3
23952 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23953 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23954       pom = ertail(k)
23955 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23956       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23957               - (( dFdR + gg(k) ) * pom)
23958 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23959 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23960 !     &             - ( dFdR * pom )
23961       pom = ertail(k)
23962 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23963       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23964               + (( dFdR + gg(k) ) * pom)
23965 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23966 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23967 !c!     &             + ( dFdR * pom )
23968
23969       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23970               - (( dFdR + gg(k) ) * ertail(k))
23971 !c!     &             - ( dFdR * ertail(k))
23972
23973       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23974               + (( dFdR + gg(k) ) * ertail(k))
23975 !c!     &             + ( dFdR * ertail(k))
23976
23977       gg(k) = 0.0d0
23978 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23979 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23980       END DO
23981
23982 !          else
23983
23984 !          endif
23985 !Now dipole-dipole
23986        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23987        w1 = wdipdip_scbase(1,itypi,itypj)
23988        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23989        w3 = wdipdip_scbase(2,itypi,itypj)
23990 !c!-------------------------------------------------------------------
23991 !c! ECL
23992        fac = (om12 - 3.0d0 * om1 * om2)
23993        c1 = (w1 / (Rhead**3.0d0)) * fac
23994        c2 = (w2 / Rhead ** 6.0d0)  &
23995        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23996        c3= (w3/ Rhead ** 6.0d0)  &
23997        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23998        ECL = c1 - c2 + c3
23999 !c!       write (*,*) "w1 = ", w1
24000 !c!       write (*,*) "w2 = ", w2
24001 !c!       write (*,*) "om1 = ", om1
24002 !c!       write (*,*) "om2 = ", om2
24003 !c!       write (*,*) "om12 = ", om12
24004 !c!       write (*,*) "fac = ", fac
24005 !c!       write (*,*) "c1 = ", c1
24006 !c!       write (*,*) "c2 = ", c2
24007 !c!       write (*,*) "Ecl = ", Ecl
24008 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24009 !c!       write (*,*) "c2_2 = ",
24010 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24011 !c!-------------------------------------------------------------------
24012 !c! dervative of ECL is GCL...
24013 !c! dECL/dr
24014        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24015        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24016        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24017        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24018        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24019        dGCLdR = c1 - c2 + c3
24020 !c! dECL/dom1
24021        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24022        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24023        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24024        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24025        dGCLdOM1 = c1 - c2 + c3
24026 !c! dECL/dom2
24027        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24028        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24029        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24030        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24031        dGCLdOM2 = c1 - c2 + c3
24032 !c! dECL/dom12
24033        c1 = w1 / (Rhead ** 3.0d0)
24034        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24035        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24036        dGCLdOM12 = c1 - c2 + c3
24037        DO k= 1, 3
24038       erhead(k) = Rhead_distance(k)/Rhead
24039        END DO
24040        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24041        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24042        facd1 = d1i * vbld_inv(i+nres)
24043        facd2 = d1j * vbld_inv(j+nres)
24044        DO k = 1, 3
24045
24046       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24047       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24048               - dGCLdR * pom
24049       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24050       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24051               + dGCLdR * pom
24052
24053       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24054               - dGCLdR * erhead(k)
24055       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24056               + dGCLdR * erhead(k)
24057        END DO
24058        endif
24059 !now charge with dipole eg. ARG-dG
24060        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24061       alphapol1 = alphapol_scbase(itypi,itypj)
24062        w1        = wqdip_scbase(1,itypi,itypj)
24063        w2        = wqdip_scbase(2,itypi,itypj)
24064 !       w1=0.0d0
24065 !       w2=0.0d0
24066 !       pis       = sig0head_scbase(itypi,itypj)
24067 !       eps_head   = epshead_scbase(itypi,itypj)
24068 !c!-------------------------------------------------------------------
24069 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24070        R1 = 0.0d0
24071        DO k = 1, 3
24072 !c! Calculate head-to-tail distances tail is center of side-chain
24073       R1=R1+(c(k,j+nres)-chead(k,1))**2
24074        END DO
24075 !c! Pitagoras
24076        R1 = dsqrt(R1)
24077
24078 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24079 !c!     &        +dhead(1,1,itypi,itypj))**2))
24080 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24081 !c!     &        +dhead(2,1,itypi,itypj))**2))
24082
24083 !c!-------------------------------------------------------------------
24084 !c! ecl
24085        sparrow  = w1  *  om1
24086        hawk     = w2 *  (1.0d0 - sqom2)
24087        Ecl = sparrow / Rhead**2.0d0 &
24088          - hawk    / Rhead**4.0d0
24089 !c!-------------------------------------------------------------------
24090 !c! derivative of ecl is Gcl
24091 !c! dF/dr part
24092        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24093             + 4.0d0 * hawk    / Rhead**5.0d0
24094 !c! dF/dom1
24095        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24096 !c! dF/dom2
24097        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24098 !c--------------------------------------------------------------------
24099 !c Polarization energy
24100 !c Epol
24101        MomoFac1 = (1.0d0 - chi1 * sqom2)
24102        RR1  = R1 * R1 / MomoFac1
24103        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24104        fgb1 = sqrt( RR1 + a12sq * ee1)
24105 !       eps_inout_fac=0.0d0
24106        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24107 ! derivative of Epol is Gpol...
24108        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24109             / (fgb1 ** 5.0d0)
24110        dFGBdR1 = ( (R1 / MomoFac1) &
24111            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24112            / ( 2.0d0 * fgb1 )
24113        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24114              * (2.0d0 - 0.5d0 * ee1) ) &
24115              / (2.0d0 * fgb1)
24116        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24117 !       dPOLdR1 = 0.0d0
24118        dPOLdOM1 = 0.0d0
24119        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24120        DO k = 1, 3
24121       erhead(k) = Rhead_distance(k)/Rhead
24122       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24123        END DO
24124
24125        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24126        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24127        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24128 !       bat=0.0d0
24129        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24130        facd1 = d1i * vbld_inv(i+nres)
24131        facd2 = d1j * vbld_inv(j+nres)
24132 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24133
24134        DO k = 1, 3
24135       hawk = (erhead_tail(k,1) + &
24136       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24137 !        facd1=0.0d0
24138 !        facd2=0.0d0
24139       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24140       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24141                - dGCLdR * pom &
24142                - dPOLdR1 *  (erhead_tail(k,1))
24143 !     &             - dGLJdR * pom
24144
24145       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24146       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24147                + dGCLdR * pom  &
24148                + dPOLdR1 * (erhead_tail(k,1))
24149 !     &             + dGLJdR * pom
24150
24151
24152       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24153               - dGCLdR * erhead(k) &
24154               - dPOLdR1 * erhead_tail(k,1)
24155 !     &             - dGLJdR * erhead(k)
24156
24157       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24158               + dGCLdR * erhead(k)  &
24159               + dPOLdR1 * erhead_tail(k,1)
24160 !     &             + dGLJdR * erhead(k)
24161
24162        END DO
24163        endif
24164 !       print *,i,j,evdwij,epol,Fcav,ECL
24165        escbase=escbase+evdwij+epol+Fcav+ECL
24166        call sc_grad_scbase
24167        enddo
24168       enddo
24169
24170       return
24171       end subroutine eprot_sc_base
24172       SUBROUTINE sc_grad_scbase
24173       use calc_data
24174
24175        real (kind=8) :: dcosom1(3),dcosom2(3)
24176        eom1  =    &
24177             eps2der * eps2rt_om1   &
24178           - 2.0D0 * alf1 * eps3der &
24179           + sigder * sigsq_om1     &
24180           + dCAVdOM1               &
24181           + dGCLdOM1               &
24182           + dPOLdOM1
24183
24184        eom2  =  &
24185             eps2der * eps2rt_om2   &
24186           + 2.0D0 * alf2 * eps3der &
24187           + sigder * sigsq_om2     &
24188           + dCAVdOM2               &
24189           + dGCLdOM2               &
24190           + dPOLdOM2
24191
24192        eom12 =    &
24193             evdwij  * eps1_om12     &
24194           + eps2der * eps2rt_om12   &
24195           - 2.0D0 * alf12 * eps3der &
24196           + sigder *sigsq_om12      &
24197           + dCAVdOM12               &
24198           + dGCLdOM12
24199
24200 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24201 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24202 !               gg(1),gg(2),"rozne"
24203        DO k = 1, 3
24204       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24205       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24206       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24207       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24208              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24209              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24210       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24211              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24212              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24213       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24214       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24215        END DO
24216        RETURN
24217       END SUBROUTINE sc_grad_scbase
24218
24219
24220       subroutine epep_sc_base(epepbase)
24221       use calc_data
24222       logical :: lprn
24223 !el local variables
24224       integer :: iint,itypi,itypi1,itypj,subchap
24225       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24226       real(kind=8) :: evdw,sig0ij
24227       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24228                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24229                 sslipi,sslipj,faclip
24230       integer :: ii
24231       real(kind=8) :: fracinbuf
24232        real (kind=8) :: epepbase
24233        real (kind=8),dimension(4):: ener
24234        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24235        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24236       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24237       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24238       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24239       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24240       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24241       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24242        real(kind=8),dimension(3,2)::chead,erhead_tail
24243        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24244        integer troll
24245        eps_out=80.0d0
24246        epepbase=0.0d0
24247 !       do i=1,nres_molec(1)-1
24248       do i=ibond_start,ibond_end
24249       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24250 !C        itypi  = itype(i,1)
24251       dxi    = dc_norm(1,i)
24252       dyi    = dc_norm(2,i)
24253       dzi    = dc_norm(3,i)
24254 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24255       dsci_inv = vbld_inv(i+1)/2.0
24256       xi=(c(1,i)+c(1,i+1))/2.0
24257       yi=(c(2,i)+c(2,i+1))/2.0
24258       zi=(c(3,i)+c(3,i+1))/2.0
24259         call to_box(xi,yi,zi)
24260        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24261          itypj= itype(j,2)
24262          if (itype(j,2).eq.ntyp1_molec(2))cycle
24263          xj=c(1,j+nres)
24264          yj=c(2,j+nres)
24265          zj=c(3,j+nres)
24266                 call to_box(xj,yj,zj)
24267       xj=boxshift(xj-xi,boxxsize)
24268       yj=boxshift(yj-yi,boxysize)
24269       zj=boxshift(zj-zi,boxzsize)
24270         dist_init=xj**2+yj**2+zj**2
24271         dxj = dc_norm( 1, nres+j )
24272         dyj = dc_norm( 2, nres+j )
24273         dzj = dc_norm( 3, nres+j )
24274 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24275 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24276
24277 ! Gay-berne var's
24278         sig0ij = sigma_pepbase(itypj )
24279         chi1   = chi_pepbase(itypj,1 )
24280         chi2   = chi_pepbase(itypj,2 )
24281 !          chi1=0.0d0
24282 !          chi2=0.0d0
24283         chi12  = chi1 * chi2
24284         chip1  = chipp_pepbase(itypj,1 )
24285         chip2  = chipp_pepbase(itypj,2 )
24286 !          chip1=0.0d0
24287 !          chip2=0.0d0
24288         chip12 = chip1 * chip2
24289         chis1 = chis_pepbase(itypj,1)
24290         chis2 = chis_pepbase(itypj,2)
24291         chis12 = chis1 * chis2
24292         sig1 = sigmap1_pepbase(itypj)
24293         sig2 = sigmap2_pepbase(itypj)
24294 !       write (*,*) "sig1 = ", sig1
24295 !       write (*,*) "sig2 = ", sig2
24296        DO k = 1,3
24297 ! location of polar head is computed by taking hydrophobic centre
24298 ! and moving by a d1 * dc_norm vector
24299 ! see unres publications for very informative images
24300       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24301 ! + d1i * dc_norm(k, i+nres)
24302       chead(k,2) = c(k, j+nres)
24303 ! + d1j * dc_norm(k, j+nres)
24304 ! distance
24305 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24306 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24307       Rhead_distance(k) = chead(k,2) - chead(k,1)
24308 !        print *,gvdwc_pepbase(k,i)
24309
24310        END DO
24311        Rhead = dsqrt( &
24312         (Rhead_distance(1)*Rhead_distance(1)) &
24313       + (Rhead_distance(2)*Rhead_distance(2)) &
24314       + (Rhead_distance(3)*Rhead_distance(3)))
24315
24316 ! alpha factors from Fcav/Gcav
24317         b1 = alphasur_pepbase(1,itypj)
24318 !          b1=0.0d0
24319         b2 = alphasur_pepbase(2,itypj)
24320         b3 = alphasur_pepbase(3,itypj)
24321         b4 = alphasur_pepbase(4,itypj)
24322         alf1   = 0.0d0
24323         alf2   = 0.0d0
24324         alf12  = 0.0d0
24325         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24326 !          print *,i,j,rrij
24327         rij  = dsqrt(rrij)
24328 !----------------------------
24329        evdwij = 0.0d0
24330        ECL = 0.0d0
24331        Elj = 0.0d0
24332        Equad = 0.0d0
24333        Epol = 0.0d0
24334        Fcav=0.0d0
24335        eheadtail = 0.0d0
24336        dGCLdOM1 = 0.0d0
24337        dGCLdOM2 = 0.0d0
24338        dGCLdOM12 = 0.0d0
24339        dPOLdOM1 = 0.0d0
24340        dPOLdOM2 = 0.0d0
24341         Fcav = 0.0d0
24342         dFdR = 0.0d0
24343         dCAVdOM1  = 0.0d0
24344         dCAVdOM2  = 0.0d0
24345         dCAVdOM12 = 0.0d0
24346         dscj_inv = vbld_inv(j+nres)
24347         CALL sc_angular
24348 ! this should be in elgrad_init but om's are calculated by sc_angular
24349 ! which in turn is used by older potentials
24350 ! om = omega, sqom = om^2
24351         sqom1  = om1 * om1
24352         sqom2  = om2 * om2
24353         sqom12 = om12 * om12
24354
24355 ! now we calculate EGB - Gey-Berne
24356 ! It will be summed up in evdwij and saved in evdw
24357         sigsq     = 1.0D0  / sigsq
24358         sig       = sig0ij * dsqrt(sigsq)
24359         rij_shift = 1.0/rij - sig + sig0ij
24360         IF (rij_shift.le.0.0D0) THEN
24361          evdw = 1.0D20
24362          RETURN
24363         END IF
24364         sigder = -sig * sigsq
24365         rij_shift = 1.0D0 / rij_shift
24366         fac       = rij_shift**expon
24367         c1        = fac  * fac * aa_pepbase(itypj)
24368 !          c1        = 0.0d0
24369         c2        = fac  * bb_pepbase(itypj)
24370 !          c2        = 0.0d0
24371         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24372         eps2der   = eps3rt * evdwij
24373         eps3der   = eps2rt * evdwij
24374 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24375         evdwij    = eps2rt * eps3rt * evdwij
24376         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24377         fac    = -expon * (c1 + evdwij) * rij_shift
24378         sigder = fac * sigder
24379 !          fac    = rij * fac
24380 ! Calculate distance derivative
24381         gg(1) =  fac
24382         gg(2) =  fac
24383         gg(3) =  fac
24384         fac = chis1 * sqom1 + chis2 * sqom2 &
24385         - 2.0d0 * chis12 * om1 * om2 * om12
24386 ! we will use pom later in Gcav, so dont mess with it!
24387         pom = 1.0d0 - chis1 * chis2 * sqom12
24388         Lambf = (1.0d0 - (fac / pom))
24389         Lambf = dsqrt(Lambf)
24390         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24391 !       write (*,*) "sparrow = ", sparrow
24392         Chif = 1.0d0/rij * sparrow
24393         ChiLambf = Chif * Lambf
24394         eagle = dsqrt(ChiLambf)
24395         bat = ChiLambf ** 11.0d0
24396         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24397         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24398         botsq = bot * bot
24399         Fcav = top / bot
24400 !          print *,i,j,Fcav
24401         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24402         dbot = 12.0d0 * b4 * bat * Lambf
24403         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24404 !       dFdR = 0.0d0
24405 !      write (*,*) "dFcav/dR = ", dFdR
24406         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24407         dbot = 12.0d0 * b4 * bat * Chif
24408         eagle = Lambf * pom
24409         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24410         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24411         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24412             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24413
24414         dFdL = ((dtop * bot - top * dbot) / botsq)
24415 !       dFdL = 0.0d0
24416         dCAVdOM1  = dFdL * ( dFdOM1 )
24417         dCAVdOM2  = dFdL * ( dFdOM2 )
24418         dCAVdOM12 = dFdL * ( dFdOM12 )
24419
24420         ertail(1) = xj*rij
24421         ertail(2) = yj*rij
24422         ertail(3) = zj*rij
24423        DO k = 1, 3
24424 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24425 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24426       pom = ertail(k)
24427 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24428       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24429               - (( dFdR + gg(k) ) * pom)/2.0
24430 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24431 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24432 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24433 !     &             - ( dFdR * pom )
24434       pom = ertail(k)
24435 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24436       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24437               + (( dFdR + gg(k) ) * pom)
24438 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24439 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24440 !c!     &             + ( dFdR * pom )
24441
24442       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24443               - (( dFdR + gg(k) ) * ertail(k))/2.0
24444 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24445
24446 !c!     &             - ( dFdR * ertail(k))
24447
24448       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24449               + (( dFdR + gg(k) ) * ertail(k))
24450 !c!     &             + ( dFdR * ertail(k))
24451
24452       gg(k) = 0.0d0
24453 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24454 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24455       END DO
24456
24457
24458        w1 = wdipdip_pepbase(1,itypj)
24459        w2 = -wdipdip_pepbase(3,itypj)/2.0
24460        w3 = wdipdip_pepbase(2,itypj)
24461 !       w1=0.0d0
24462 !       w2=0.0d0
24463 !c!-------------------------------------------------------------------
24464 !c! ECL
24465 !       w3=0.0d0
24466        fac = (om12 - 3.0d0 * om1 * om2)
24467        c1 = (w1 / (Rhead**3.0d0)) * fac
24468        c2 = (w2 / Rhead ** 6.0d0)  &
24469        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24470        c3= (w3/ Rhead ** 6.0d0)  &
24471        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24472
24473        ECL = c1 - c2 + c3
24474
24475        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24476        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24477        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24478        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24479        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24480
24481        dGCLdR = c1 - c2 + c3
24482 !c! dECL/dom1
24483        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24484        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24485        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24486        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24487        dGCLdOM1 = c1 - c2 + c3
24488 !c! dECL/dom2
24489        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24490        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24491        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24492        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24493
24494        dGCLdOM2 = c1 - c2 + c3
24495 !c! dECL/dom12
24496        c1 = w1 / (Rhead ** 3.0d0)
24497        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24498        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24499        dGCLdOM12 = c1 - c2 + c3
24500        DO k= 1, 3
24501       erhead(k) = Rhead_distance(k)/Rhead
24502        END DO
24503        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24504        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24505 !       facd1 = d1 * vbld_inv(i+nres)
24506 !       facd2 = d2 * vbld_inv(j+nres)
24507        DO k = 1, 3
24508
24509 !        pom = erhead(k)
24510 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24511 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24512 !                  - dGCLdR * pom
24513       pom = erhead(k)
24514 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24515       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24516               + dGCLdR * pom
24517
24518       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24519               - dGCLdR * erhead(k)/2.0d0
24520 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24521       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24522               - dGCLdR * erhead(k)/2.0d0
24523 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24524       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24525               + dGCLdR * erhead(k)
24526        END DO
24527 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24528        epepbase=epepbase+evdwij+Fcav+ECL
24529        call sc_grad_pepbase
24530        enddo
24531        enddo
24532       END SUBROUTINE epep_sc_base
24533       SUBROUTINE sc_grad_pepbase
24534       use calc_data
24535
24536        real (kind=8) :: dcosom1(3),dcosom2(3)
24537        eom1  =    &
24538             eps2der * eps2rt_om1   &
24539           - 2.0D0 * alf1 * eps3der &
24540           + sigder * sigsq_om1     &
24541           + dCAVdOM1               &
24542           + dGCLdOM1               &
24543           + dPOLdOM1
24544
24545        eom2  =  &
24546             eps2der * eps2rt_om2   &
24547           + 2.0D0 * alf2 * eps3der &
24548           + sigder * sigsq_om2     &
24549           + dCAVdOM2               &
24550           + dGCLdOM2               &
24551           + dPOLdOM2
24552
24553        eom12 =    &
24554             evdwij  * eps1_om12     &
24555           + eps2der * eps2rt_om12   &
24556           - 2.0D0 * alf12 * eps3der &
24557           + sigder *sigsq_om12      &
24558           + dCAVdOM12               &
24559           + dGCLdOM12
24560 !        om12=0.0
24561 !        eom12=0.0
24562 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24563 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24564 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24565 !                 *dsci_inv*2.0
24566 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24567 !               gg(1),gg(2),"rozne"
24568        DO k = 1, 3
24569       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24570       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24571       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24572       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24573              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24574              *dsci_inv*2.0 &
24575              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24576       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24577              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24578              *dsci_inv*2.0 &
24579              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24580 !         print *,eom12,eom2,om12,om2
24581 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24582 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24583       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24584              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24585              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24586       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24587        END DO
24588        RETURN
24589       END SUBROUTINE sc_grad_pepbase
24590       subroutine eprot_sc_phosphate(escpho)
24591       use calc_data
24592 !      implicit real*8 (a-h,o-z)
24593 !      include 'DIMENSIONS'
24594 !      include 'COMMON.GEO'
24595 !      include 'COMMON.VAR'
24596 !      include 'COMMON.LOCAL'
24597 !      include 'COMMON.CHAIN'
24598 !      include 'COMMON.DERIV'
24599 !      include 'COMMON.NAMES'
24600 !      include 'COMMON.INTERACT'
24601 !      include 'COMMON.IOUNITS'
24602 !      include 'COMMON.CALC'
24603 !      include 'COMMON.CONTROL'
24604 !      include 'COMMON.SBRIDGE'
24605       logical :: lprn
24606 !el local variables
24607       integer :: iint,itypi,itypi1,itypj,subchap
24608       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24609       real(kind=8) :: evdw,sig0ij,aa,bb
24610       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24611                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24612                 sslipi,sslipj,faclip,alpha_sco
24613       integer :: ii
24614       real(kind=8) :: fracinbuf
24615        real (kind=8) :: escpho
24616        real (kind=8),dimension(4):: ener
24617        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24618        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24619       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24620       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24621       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24622       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24623       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24624       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24625        real(kind=8),dimension(3,2)::chead,erhead_tail
24626        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24627        integer troll
24628        eps_out=80.0d0
24629        escpho=0.0d0
24630 !       do i=1,nres_molec(1)
24631       do i=ibond_start,ibond_end
24632       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24633       itypi  = itype(i,1)
24634       dxi    = dc_norm(1,nres+i)
24635       dyi    = dc_norm(2,nres+i)
24636       dzi    = dc_norm(3,nres+i)
24637       dsci_inv = vbld_inv(i+nres)
24638       xi=c(1,nres+i)
24639       yi=c(2,nres+i)
24640       zi=c(3,nres+i)
24641        call to_box(xi,yi,zi)
24642       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24643        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24644          itypj= itype(j,2)
24645          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24646           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24647          xj=(c(1,j)+c(1,j+1))/2.0
24648          yj=(c(2,j)+c(2,j+1))/2.0
24649          zj=(c(3,j)+c(3,j+1))/2.0
24650      call to_box(xj,yj,zj)
24651 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24652 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24653 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24654 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24655 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24656       xj=boxshift(xj-xi,boxxsize)
24657       yj=boxshift(yj-yi,boxysize)
24658       zj=boxshift(zj-zi,boxzsize)
24659           dxj = dc_norm( 1,j )
24660         dyj = dc_norm( 2,j )
24661         dzj = dc_norm( 3,j )
24662         dscj_inv = vbld_inv(j+1)
24663
24664 ! Gay-berne var's
24665         sig0ij = sigma_scpho(itypi )
24666         chi1   = chi_scpho(itypi,1 )
24667         chi2   = chi_scpho(itypi,2 )
24668 !          chi1=0.0d0
24669 !          chi2=0.0d0
24670         chi12  = chi1 * chi2
24671         chip1  = chipp_scpho(itypi,1 )
24672         chip2  = chipp_scpho(itypi,2 )
24673 !          chip1=0.0d0
24674 !          chip2=0.0d0
24675         chip12 = chip1 * chip2
24676         chis1 = chis_scpho(itypi,1)
24677         chis2 = chis_scpho(itypi,2)
24678         chis12 = chis1 * chis2
24679         sig1 = sigmap1_scpho(itypi)
24680         sig2 = sigmap2_scpho(itypi)
24681 !       write (*,*) "sig1 = ", sig1
24682 !       write (*,*) "sig1 = ", sig1
24683 !       write (*,*) "sig2 = ", sig2
24684 ! alpha factors from Fcav/Gcav
24685         alf1   = 0.0d0
24686         alf2   = 0.0d0
24687         alf12  = 0.0d0
24688         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24689
24690         b1 = alphasur_scpho(1,itypi)
24691 !          b1=0.0d0
24692         b2 = alphasur_scpho(2,itypi)
24693         b3 = alphasur_scpho(3,itypi)
24694         b4 = alphasur_scpho(4,itypi)
24695 ! used to determine whether we want to do quadrupole calculations
24696 ! used by Fgb
24697        eps_in = epsintab_scpho(itypi)
24698        if (eps_in.eq.0.0) eps_in=1.0
24699        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24700 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24701 !-------------------------------------------------------------------
24702 ! tail location and distance calculations
24703         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24704         d1j = 0.0
24705        DO k = 1,3
24706 ! location of polar head is computed by taking hydrophobic centre
24707 ! and moving by a d1 * dc_norm vector
24708 ! see unres publications for very informative images
24709       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24710       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24711 ! distance
24712 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24713 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24714       Rhead_distance(k) = chead(k,2) - chead(k,1)
24715        END DO
24716 ! pitagoras (root of sum of squares)
24717        Rhead = dsqrt( &
24718         (Rhead_distance(1)*Rhead_distance(1)) &
24719       + (Rhead_distance(2)*Rhead_distance(2)) &
24720       + (Rhead_distance(3)*Rhead_distance(3)))
24721        Rhead_sq=Rhead**2.0
24722 !-------------------------------------------------------------------
24723 ! zero everything that should be zero'ed
24724        evdwij = 0.0d0
24725        ECL = 0.0d0
24726        Elj = 0.0d0
24727        Equad = 0.0d0
24728        Epol = 0.0d0
24729        Fcav=0.0d0
24730        eheadtail = 0.0d0
24731        dGCLdR=0.0d0
24732        dGCLdOM1 = 0.0d0
24733        dGCLdOM2 = 0.0d0
24734        dGCLdOM12 = 0.0d0
24735        dPOLdOM1 = 0.0d0
24736        dPOLdOM2 = 0.0d0
24737         Fcav = 0.0d0
24738         dFdR = 0.0d0
24739         dCAVdOM1  = 0.0d0
24740         dCAVdOM2  = 0.0d0
24741         dCAVdOM12 = 0.0d0
24742         dscj_inv = vbld_inv(j+1)/2.0
24743 !dhead_scbasej(itypi,itypj)
24744 !          print *,i,j,dscj_inv,dsci_inv
24745 ! rij holds 1/(distance of Calpha atoms)
24746         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24747         rij  = dsqrt(rrij)
24748 !----------------------------
24749         CALL sc_angular
24750 ! this should be in elgrad_init but om's are calculated by sc_angular
24751 ! which in turn is used by older potentials
24752 ! om = omega, sqom = om^2
24753         sqom1  = om1 * om1
24754         sqom2  = om2 * om2
24755         sqom12 = om12 * om12
24756
24757 ! now we calculate EGB - Gey-Berne
24758 ! It will be summed up in evdwij and saved in evdw
24759         sigsq     = 1.0D0  / sigsq
24760         sig       = sig0ij * dsqrt(sigsq)
24761 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24762         rij_shift = 1.0/rij - sig + sig0ij
24763         IF (rij_shift.le.0.0D0) THEN
24764          evdw = 1.0D20
24765          RETURN
24766         END IF
24767         sigder = -sig * sigsq
24768         rij_shift = 1.0D0 / rij_shift
24769         fac       = rij_shift**expon
24770         c1        = fac  * fac * aa_scpho(itypi)
24771 !          c1        = 0.0d0
24772         c2        = fac  * bb_scpho(itypi)
24773 !          c2        = 0.0d0
24774         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24775         eps2der   = eps3rt * evdwij
24776         eps3der   = eps2rt * evdwij
24777 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24778         evdwij    = eps2rt * eps3rt * evdwij
24779         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24780         fac    = -expon * (c1 + evdwij) * rij_shift
24781         sigder = fac * sigder
24782 !          fac    = rij * fac
24783 ! Calculate distance derivative
24784         gg(1) =  fac
24785         gg(2) =  fac
24786         gg(3) =  fac
24787         fac = chis1 * sqom1 + chis2 * sqom2 &
24788         - 2.0d0 * chis12 * om1 * om2 * om12
24789 ! we will use pom later in Gcav, so dont mess with it!
24790         pom = 1.0d0 - chis1 * chis2 * sqom12
24791         Lambf = (1.0d0 - (fac / pom))
24792         Lambf = dsqrt(Lambf)
24793         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24794 !       write (*,*) "sparrow = ", sparrow
24795         Chif = 1.0d0/rij * sparrow
24796         ChiLambf = Chif * Lambf
24797         eagle = dsqrt(ChiLambf)
24798         bat = ChiLambf ** 11.0d0
24799         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24800         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24801         botsq = bot * bot
24802         Fcav = top / bot
24803         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24804         dbot = 12.0d0 * b4 * bat * Lambf
24805         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24806 !       dFdR = 0.0d0
24807 !      write (*,*) "dFcav/dR = ", dFdR
24808         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24809         dbot = 12.0d0 * b4 * bat * Chif
24810         eagle = Lambf * pom
24811         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24812         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24813         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24814             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24815
24816         dFdL = ((dtop * bot - top * dbot) / botsq)
24817 !       dFdL = 0.0d0
24818         dCAVdOM1  = dFdL * ( dFdOM1 )
24819         dCAVdOM2  = dFdL * ( dFdOM2 )
24820         dCAVdOM12 = dFdL * ( dFdOM12 )
24821
24822         ertail(1) = xj*rij
24823         ertail(2) = yj*rij
24824         ertail(3) = zj*rij
24825        DO k = 1, 3
24826 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24827 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24828 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24829
24830       pom = ertail(k)
24831 !        print *,pom,gg(k),dFdR
24832 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24833       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24834               - (( dFdR + gg(k) ) * pom)
24835 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24836 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24837 !     &             - ( dFdR * pom )
24838 !        pom = ertail(k)
24839 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24840 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24841 !                  + (( dFdR + gg(k) ) * pom)
24842 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24843 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24844 !c!     &             + ( dFdR * pom )
24845
24846       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24847               - (( dFdR + gg(k) ) * ertail(k))
24848 !c!     &             - ( dFdR * ertail(k))
24849
24850       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24851               + (( dFdR + gg(k) ) * ertail(k))/2.0
24852
24853       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24854               + (( dFdR + gg(k) ) * ertail(k))/2.0
24855
24856 !c!     &             + ( dFdR * ertail(k))
24857
24858       gg(k) = 0.0d0
24859       ENDDO
24860 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24861 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24862 !      alphapol1 = alphapol_scpho(itypi)
24863        if (wqq_scpho(itypi).ne.0.0) then
24864        Qij=wqq_scpho(itypi)/eps_in
24865        alpha_sco=1.d0/alphi_scpho(itypi)
24866 !       Qij=0.0
24867        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24868 !c! derivative of Ecl is Gcl...
24869        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24870             (Rhead*alpha_sco+1) ) / Rhead_sq
24871        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24872        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24873        w1        = wqdip_scpho(1,itypi)
24874        w2        = wqdip_scpho(2,itypi)
24875 !       w1=0.0d0
24876 !       w2=0.0d0
24877 !       pis       = sig0head_scbase(itypi,itypj)
24878 !       eps_head   = epshead_scbase(itypi,itypj)
24879 !c!-------------------------------------------------------------------
24880
24881 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24882 !c!     &        +dhead(1,1,itypi,itypj))**2))
24883 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24884 !c!     &        +dhead(2,1,itypi,itypj))**2))
24885
24886 !c!-------------------------------------------------------------------
24887 !c! ecl
24888        sparrow  = w1  *  om1
24889        hawk     = w2 *  (1.0d0 - sqom2)
24890        Ecl = sparrow / Rhead**2.0d0 &
24891          - hawk    / Rhead**4.0d0
24892 !c!-------------------------------------------------------------------
24893        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24894          1.0/rij,sparrow
24895
24896 !c! derivative of ecl is Gcl
24897 !c! dF/dr part
24898        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24899             + 4.0d0 * hawk    / Rhead**5.0d0
24900 !c! dF/dom1
24901        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24902 !c! dF/dom2
24903        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24904        endif
24905
24906 !c--------------------------------------------------------------------
24907 !c Polarization energy
24908 !c Epol
24909        R1 = 0.0d0
24910        DO k = 1, 3
24911 !c! Calculate head-to-tail distances tail is center of side-chain
24912       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24913        END DO
24914 !c! Pitagoras
24915        R1 = dsqrt(R1)
24916
24917       alphapol1 = alphapol_scpho(itypi)
24918 !      alphapol1=0.0
24919        MomoFac1 = (1.0d0 - chi2 * sqom1)
24920        RR1  = R1 * R1 / MomoFac1
24921        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24922 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24923        fgb1 = sqrt( RR1 + a12sq * ee1)
24924 !       eps_inout_fac=0.0d0
24925        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24926 ! derivative of Epol is Gpol...
24927        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24928             / (fgb1 ** 5.0d0)
24929        dFGBdR1 = ( (R1 / MomoFac1) &
24930            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24931            / ( 2.0d0 * fgb1 )
24932        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24933              * (2.0d0 - 0.5d0 * ee1) ) &
24934              / (2.0d0 * fgb1)
24935        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24936 !       dPOLdR1 = 0.0d0
24937 !       dPOLdOM1 = 0.0d0
24938        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24939              * (2.0d0 - 0.5d0 * ee1) ) &
24940              / (2.0d0 * fgb1)
24941
24942        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24943        dPOLdOM2 = 0.0
24944        DO k = 1, 3
24945       erhead(k) = Rhead_distance(k)/Rhead
24946       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24947        END DO
24948
24949        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24950        erdxj = scalar( erhead(1), dC_norm(1,j) )
24951        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24952 !       bat=0.0d0
24953        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24954        facd1 = d1i * vbld_inv(i+nres)
24955        facd2 = d1j * vbld_inv(j)
24956 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24957
24958        DO k = 1, 3
24959       hawk = (erhead_tail(k,1) + &
24960       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24961 !        facd1=0.0d0
24962 !        facd2=0.0d0
24963 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24964 !                pom,(erhead_tail(k,1))
24965
24966 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24967       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24968       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24969                - dGCLdR * pom &
24970                - dPOLdR1 *  (erhead_tail(k,1))
24971 !     &             - dGLJdR * pom
24972
24973       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24974 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24975 !                   + dGCLdR * pom  &
24976 !                   + dPOLdR1 * (erhead_tail(k,1))
24977 !     &             + dGLJdR * pom
24978
24979
24980       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24981               - dGCLdR * erhead(k) &
24982               - dPOLdR1 * erhead_tail(k,1)
24983 !     &             - dGLJdR * erhead(k)
24984
24985       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24986               + (dGCLdR * erhead(k)  &
24987               + dPOLdR1 * erhead_tail(k,1))/2.0
24988       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24989               + (dGCLdR * erhead(k)  &
24990               + dPOLdR1 * erhead_tail(k,1))/2.0
24991
24992 !     &             + dGLJdR * erhead(k)
24993 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24994
24995        END DO
24996 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24997        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24998       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24999        escpho=escpho+evdwij+epol+Fcav+ECL
25000        call sc_grad_scpho
25001        enddo
25002
25003       enddo
25004
25005       return
25006       end subroutine eprot_sc_phosphate
25007       SUBROUTINE sc_grad_scpho
25008       use calc_data
25009
25010        real (kind=8) :: dcosom1(3),dcosom2(3)
25011        eom1  =    &
25012             eps2der * eps2rt_om1   &
25013           - 2.0D0 * alf1 * eps3der &
25014           + sigder * sigsq_om1     &
25015           + dCAVdOM1               &
25016           + dGCLdOM1               &
25017           + dPOLdOM1
25018
25019        eom2  =  &
25020             eps2der * eps2rt_om2   &
25021           + 2.0D0 * alf2 * eps3der &
25022           + sigder * sigsq_om2     &
25023           + dCAVdOM2               &
25024           + dGCLdOM2               &
25025           + dPOLdOM2
25026
25027        eom12 =    &
25028             evdwij  * eps1_om12     &
25029           + eps2der * eps2rt_om12   &
25030           - 2.0D0 * alf12 * eps3der &
25031           + sigder *sigsq_om12      &
25032           + dCAVdOM12               &
25033           + dGCLdOM12
25034 !        om12=0.0
25035 !        eom12=0.0
25036 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25037 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25038 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25039 !                 *dsci_inv*2.0
25040 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25041 !               gg(1),gg(2),"rozne"
25042        DO k = 1, 3
25043       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25044       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25045       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25046       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25047              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25048              *dscj_inv*2.0 &
25049              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25050       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25051              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25052              *dscj_inv*2.0 &
25053              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25054       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25055              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25056              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25057
25058 !         print *,eom12,eom2,om12,om2
25059 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25060 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25061 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25062 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25063 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25064       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25065        END DO
25066        RETURN
25067       END SUBROUTINE sc_grad_scpho
25068       subroutine eprot_pep_phosphate(epeppho)
25069       use calc_data
25070 !      implicit real*8 (a-h,o-z)
25071 !      include 'DIMENSIONS'
25072 !      include 'COMMON.GEO'
25073 !      include 'COMMON.VAR'
25074 !      include 'COMMON.LOCAL'
25075 !      include 'COMMON.CHAIN'
25076 !      include 'COMMON.DERIV'
25077 !      include 'COMMON.NAMES'
25078 !      include 'COMMON.INTERACT'
25079 !      include 'COMMON.IOUNITS'
25080 !      include 'COMMON.CALC'
25081 !      include 'COMMON.CONTROL'
25082 !      include 'COMMON.SBRIDGE'
25083       logical :: lprn
25084 !el local variables
25085       integer :: iint,itypi,itypi1,itypj,subchap
25086       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25087       real(kind=8) :: evdw,sig0ij
25088       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25089                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25090                 sslipi,sslipj,faclip
25091       integer :: ii
25092       real(kind=8) :: fracinbuf
25093        real (kind=8) :: epeppho
25094        real (kind=8),dimension(4):: ener
25095        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25096        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25097       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25098       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25099       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25100       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25101       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25102       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25103        real(kind=8),dimension(3,2)::chead,erhead_tail
25104        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25105        integer troll
25106        real (kind=8) :: dcosom1(3),dcosom2(3)
25107        epeppho=0.0d0
25108 !       do i=1,nres_molec(1)
25109       do i=ibond_start,ibond_end
25110       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25111       itypi  = itype(i,1)
25112       dsci_inv = vbld_inv(i+1)/2.0
25113       dxi    = dc_norm(1,i)
25114       dyi    = dc_norm(2,i)
25115       dzi    = dc_norm(3,i)
25116       xi=(c(1,i)+c(1,i+1))/2.0
25117       yi=(c(2,i)+c(2,i+1))/2.0
25118       zi=(c(3,i)+c(3,i+1))/2.0
25119                call to_box(xi,yi,zi)
25120
25121         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25122          itypj= itype(j,2)
25123          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25124           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25125          xj=(c(1,j)+c(1,j+1))/2.0
25126          yj=(c(2,j)+c(2,j+1))/2.0
25127          zj=(c(3,j)+c(3,j+1))/2.0
25128                 call to_box(xj,yj,zj)
25129       xj=boxshift(xj-xi,boxxsize)
25130       yj=boxshift(yj-yi,boxysize)
25131       zj=boxshift(zj-zi,boxzsize)
25132
25133         dist_init=xj**2+yj**2+zj**2
25134         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25135         rij  = dsqrt(rrij)
25136         dxj = dc_norm( 1,j )
25137         dyj = dc_norm( 2,j )
25138         dzj = dc_norm( 3,j )
25139         dscj_inv = vbld_inv(j+1)/2.0
25140 ! Gay-berne var's
25141         sig0ij = sigma_peppho
25142 !          chi1=0.0d0
25143 !          chi2=0.0d0
25144         chi12  = chi1 * chi2
25145 !          chip1=0.0d0
25146 !          chip2=0.0d0
25147         chip12 = chip1 * chip2
25148 !          chis1 = 0.0d0
25149 !          chis2 = 0.0d0
25150         chis12 = chis1 * chis2
25151         sig1 = sigmap1_peppho
25152         sig2 = sigmap2_peppho
25153 !       write (*,*) "sig1 = ", sig1
25154 !       write (*,*) "sig1 = ", sig1
25155 !       write (*,*) "sig2 = ", sig2
25156 ! alpha factors from Fcav/Gcav
25157         alf1   = 0.0d0
25158         alf2   = 0.0d0
25159         alf12  = 0.0d0
25160         b1 = alphasur_peppho(1)
25161 !          b1=0.0d0
25162         b2 = alphasur_peppho(2)
25163         b3 = alphasur_peppho(3)
25164         b4 = alphasur_peppho(4)
25165         CALL sc_angular
25166        sqom1=om1*om1
25167        evdwij = 0.0d0
25168        ECL = 0.0d0
25169        Elj = 0.0d0
25170        Equad = 0.0d0
25171        Epol = 0.0d0
25172        Fcav=0.0d0
25173        eheadtail = 0.0d0
25174        dGCLdR=0.0d0
25175        dGCLdOM1 = 0.0d0
25176        dGCLdOM2 = 0.0d0
25177        dGCLdOM12 = 0.0d0
25178        dPOLdOM1 = 0.0d0
25179        dPOLdOM2 = 0.0d0
25180         Fcav = 0.0d0
25181         dFdR = 0.0d0
25182         dCAVdOM1  = 0.0d0
25183         dCAVdOM2  = 0.0d0
25184         dCAVdOM12 = 0.0d0
25185         rij_shift = rij
25186         fac       = rij_shift**expon
25187         c1        = fac  * fac * aa_peppho
25188 !          c1        = 0.0d0
25189         c2        = fac  * bb_peppho
25190 !          c2        = 0.0d0
25191         evdwij    =  c1 + c2
25192 ! Now cavity....................
25193        eagle = dsqrt(1.0/rij_shift)
25194        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25195         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25196         botsq = bot * bot
25197         Fcav = top / bot
25198         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25199         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25200         dFdR = ((dtop * bot - top * dbot) / botsq)
25201        w1        = wqdip_peppho(1)
25202        w2        = wqdip_peppho(2)
25203 !       w1=0.0d0
25204 !       w2=0.0d0
25205 !       pis       = sig0head_scbase(itypi,itypj)
25206 !       eps_head   = epshead_scbase(itypi,itypj)
25207 !c!-------------------------------------------------------------------
25208
25209 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25210 !c!     &        +dhead(1,1,itypi,itypj))**2))
25211 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25212 !c!     &        +dhead(2,1,itypi,itypj))**2))
25213
25214 !c!-------------------------------------------------------------------
25215 !c! ecl
25216        sparrow  = w1  *  om1
25217        hawk     = w2 *  (1.0d0 - sqom1)
25218        Ecl = sparrow * rij_shift**2.0d0 &
25219          - hawk    * rij_shift**4.0d0
25220 !c!-------------------------------------------------------------------
25221 !c! derivative of ecl is Gcl
25222 !c! dF/dr part
25223 !       rij_shift=5.0
25224        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25225             + 4.0d0 * hawk    * rij_shift**5.0d0
25226 !c! dF/dom1
25227        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25228 !c! dF/dom2
25229        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25230        eom1  =    dGCLdOM1+dGCLdOM2
25231        eom2  =    0.0
25232
25233         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25234 !          fac=0.0
25235         gg(1) =  fac*xj*rij
25236         gg(2) =  fac*yj*rij
25237         gg(3) =  fac*zj*rij
25238        do k=1,3
25239        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25240        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25241        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25242        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25243        gg(k)=0.0
25244        enddo
25245
25246       DO k = 1, 3
25247       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25248       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25249       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25250       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25251 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25252       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25253 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25254       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25255              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25256       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25257              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25258       enddo
25259        epeppho=epeppho+evdwij+Fcav+ECL
25260 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25261        enddo
25262        enddo
25263       end subroutine eprot_pep_phosphate
25264 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25265       subroutine emomo(evdw)
25266       use calc_data
25267       use comm_momo
25268 !      implicit real*8 (a-h,o-z)
25269 !      include 'DIMENSIONS'
25270 !      include 'COMMON.GEO'
25271 !      include 'COMMON.VAR'
25272 !      include 'COMMON.LOCAL'
25273 !      include 'COMMON.CHAIN'
25274 !      include 'COMMON.DERIV'
25275 !      include 'COMMON.NAMES'
25276 !      include 'COMMON.INTERACT'
25277 !      include 'COMMON.IOUNITS'
25278 !      include 'COMMON.CALC'
25279 !      include 'COMMON.CONTROL'
25280 !      include 'COMMON.SBRIDGE'
25281       logical :: lprn
25282 !el local variables
25283       integer :: iint,itypi1,subchap,isel
25284       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25285       real(kind=8) :: evdw,aa,bb
25286       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25287                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25288                 sslipi,sslipj,faclip,alpha_sco
25289       integer :: ii
25290       real(kind=8) :: fracinbuf
25291        real (kind=8) :: escpho
25292        real (kind=8),dimension(4):: ener
25293        real(kind=8) :: b1,b2,egb
25294        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25295       Lambf,&
25296       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25297       dFdOM2,dFdL,dFdOM12,&
25298       federmaus,&
25299       d1i,d1j
25300 !       real(kind=8),dimension(3,2)::erhead_tail
25301 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25302        real(kind=8) ::  facd4, adler, Fgb, facd3
25303        integer troll,jj,istate
25304        real (kind=8) :: dcosom1(3),dcosom2(3)
25305        evdw=0.0d0
25306        eps_out=80.0d0
25307        sss_ele_cut=1.0d0
25308 !       print *,"EVDW KURW",evdw,nres
25309       do i=iatsc_s,iatsc_e
25310 !        print *,"I am in EVDW",i
25311       itypi=iabs(itype(i,1))
25312 !        if (i.ne.47) cycle
25313       if (itypi.eq.ntyp1) cycle
25314       itypi1=iabs(itype(i+1,1))
25315       xi=c(1,nres+i)
25316       yi=c(2,nres+i)
25317       zi=c(3,nres+i)
25318         call to_box(xi,yi,zi)
25319         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25320 !       endif
25321 !       print *, sslipi,ssgradlipi
25322       dxi=dc_norm(1,nres+i)
25323       dyi=dc_norm(2,nres+i)
25324       dzi=dc_norm(3,nres+i)
25325 !        dsci_inv=dsc_inv(itypi)
25326       dsci_inv=vbld_inv(i+nres)
25327 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25328 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25329 !
25330 ! Calculate SC interaction energy.
25331 !
25332       do iint=1,nint_gr(i)
25333         do j=istart(i,iint),iend(i,iint)
25334 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25335           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25336             call dyn_ssbond_ene(i,j,evdwij)
25337             evdw=evdw+evdwij
25338             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25339                         'evdw',i,j,evdwij,' ss'
25340 !              if (energy_dec) write (iout,*) &
25341 !                              'evdw',i,j,evdwij,' ss'
25342            do k=j+1,iend(i,iint)
25343 !C search over all next residues
25344             if (dyn_ss_mask(k)) then
25345 !C check if they are cysteins
25346 !C              write(iout,*) 'k=',k
25347
25348 !c              write(iout,*) "PRZED TRI", evdwij
25349 !               evdwij_przed_tri=evdwij
25350             call triple_ssbond_ene(i,j,k,evdwij)
25351 !c               if(evdwij_przed_tri.ne.evdwij) then
25352 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25353 !c               endif
25354
25355 !c              write(iout,*) "PO TRI", evdwij
25356 !C call the energy function that removes the artifical triple disulfide
25357 !C bond the soubroutine is located in ssMD.F
25358             evdw=evdw+evdwij
25359             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25360                       'evdw',i,j,evdwij,'tss'
25361             endif!dyn_ss_mask(k)
25362            enddo! k
25363           ELSE
25364 !el            ind=ind+1
25365           itypj=iabs(itype(j,1))
25366           if (itypj.eq.ntyp1) cycle
25367            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25368
25369 !             if (j.ne.78) cycle
25370 !            dscj_inv=dsc_inv(itypj)
25371           dscj_inv=vbld_inv(j+nres)
25372          xj=c(1,j+nres)
25373          yj=c(2,j+nres)
25374          zj=c(3,j+nres)
25375      call to_box(xj,yj,zj)
25376      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25377 !      write(iout,*) "KRUWA", i,j
25378       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25379       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25380       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25381       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25382       xj=boxshift(xj-xi,boxxsize)
25383       yj=boxshift(yj-yi,boxysize)
25384       zj=boxshift(zj-zi,boxzsize)
25385         dxj = dc_norm( 1, nres+j )
25386         dyj = dc_norm( 2, nres+j )
25387         dzj = dc_norm( 3, nres+j )
25388 !          print *,i,j,itypi,itypj
25389 !          d1i=0.0d0
25390 !          d1j=0.0d0
25391 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25392 ! Gay-berne var's
25393 !1!          sig0ij = sigma_scsc( itypi,itypj )
25394 !          chi1=0.0d0
25395 !          chi2=0.0d0
25396 !          chip1=0.0d0
25397 !          chip2=0.0d0
25398 ! not used by momo potential, but needed by sc_angular which is shared
25399 ! by all energy_potential subroutines
25400         alf1   = 0.0d0
25401         alf2   = 0.0d0
25402         alf12  = 0.0d0
25403         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25404 !       a12sq = a12sq * a12sq
25405 ! charge of amino acid itypi is...
25406         chis1 = chis(itypi,itypj)
25407         chis2 = chis(itypj,itypi)
25408         chis12 = chis1 * chis2
25409         sig1 = sigmap1(itypi,itypj)
25410         sig2 = sigmap2(itypi,itypj)
25411 !       write (*,*) "sig1 = ", sig1
25412 !          chis1=0.0
25413 !          chis2=0.0
25414 !                    chis12 = chis1 * chis2
25415 !          sig1=0.0
25416 !          sig2=0.0
25417 !       write (*,*) "sig2 = ", sig2
25418 ! alpha factors from Fcav/Gcav
25419         b1cav = alphasur(1,itypi,itypj)
25420 !          b1cav=0.0d0
25421         b2cav = alphasur(2,itypi,itypj)
25422         b3cav = alphasur(3,itypi,itypj)
25423         b4cav = alphasur(4,itypi,itypj)
25424 ! used to determine whether we want to do quadrupole calculations
25425        eps_in = epsintab(itypi,itypj)
25426        if (eps_in.eq.0.0) eps_in=1.0
25427
25428        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25429        Rtail = 0.0d0
25430 !       dtail(1,itypi,itypj)=0.0
25431 !       dtail(2,itypi,itypj)=0.0
25432
25433        DO k = 1, 3
25434       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25435       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25436        END DO
25437 !c! tail distances will be themselves usefull elswhere
25438 !c1 (in Gcav, for example)
25439        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25440        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25441        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25442        Rtail = dsqrt( &
25443         (Rtail_distance(1)*Rtail_distance(1)) &
25444       + (Rtail_distance(2)*Rtail_distance(2)) &
25445       + (Rtail_distance(3)*Rtail_distance(3)))
25446
25447 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25448 !-------------------------------------------------------------------
25449 ! tail location and distance calculations
25450        d1 = dhead(1, 1, itypi, itypj)
25451        d2 = dhead(2, 1, itypi, itypj)
25452
25453        DO k = 1,3
25454 ! location of polar head is computed by taking hydrophobic centre
25455 ! and moving by a d1 * dc_norm vector
25456 ! see unres publications for very informative images
25457       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25458       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25459 ! distance
25460 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25461 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25462       Rhead_distance(k) = chead(k,2) - chead(k,1)
25463        END DO
25464 ! pitagoras (root of sum of squares)
25465        Rhead = dsqrt( &
25466         (Rhead_distance(1)*Rhead_distance(1)) &
25467       + (Rhead_distance(2)*Rhead_distance(2)) &
25468       + (Rhead_distance(3)*Rhead_distance(3)))
25469 !-------------------------------------------------------------------
25470 ! zero everything that should be zero'ed
25471        evdwij = 0.0d0
25472        ECL = 0.0d0
25473        Elj = 0.0d0
25474        Equad = 0.0d0
25475        Epol = 0.0d0
25476        Fcav=0.0d0
25477        eheadtail = 0.0d0
25478        dGCLdOM1 = 0.0d0
25479        dGCLdOM2 = 0.0d0
25480        dGCLdOM12 = 0.0d0
25481        dPOLdOM1 = 0.0d0
25482        dPOLdOM2 = 0.0d0
25483         Fcav = 0.0d0
25484         dFdR = 0.0d0
25485         dCAVdOM1  = 0.0d0
25486         dCAVdOM2  = 0.0d0
25487         dCAVdOM12 = 0.0d0
25488         dscj_inv = vbld_inv(j+nres)
25489 !          print *,i,j,dscj_inv,dsci_inv
25490 ! rij holds 1/(distance of Calpha atoms)
25491         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25492         rij  = dsqrt(rrij)
25493 !----------------------------
25494         CALL sc_angular
25495 ! this should be in elgrad_init but om's are calculated by sc_angular
25496 ! which in turn is used by older potentials
25497 ! om = omega, sqom = om^2
25498         sqom1  = om1 * om1
25499         sqom2  = om2 * om2
25500         sqom12 = om12 * om12
25501
25502 ! now we calculate EGB - Gey-Berne
25503 ! It will be summed up in evdwij and saved in evdw
25504         sigsq     = 1.0D0  / sigsq
25505         sig       = sig0ij * dsqrt(sigsq)
25506 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25507         rij_shift = Rtail - sig + sig0ij
25508         IF (rij_shift.le.0.0D0) THEN
25509          evdw = 1.0D20
25510          RETURN
25511         END IF
25512         sigder = -sig * sigsq
25513         rij_shift = 1.0D0 / rij_shift
25514         fac       = rij_shift**expon
25515         c1        = fac  * fac * aa_aq(itypi,itypj)
25516 !          print *,"ADAM",aa_aq(itypi,itypj)
25517
25518 !          c1        = 0.0d0
25519         c2        = fac  * bb_aq(itypi,itypj)
25520 !          c2        = 0.0d0
25521         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25522         eps2der   = eps3rt * evdwij
25523         eps3der   = eps2rt * evdwij
25524 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25525         evdwij    = eps2rt * eps3rt * evdwij
25526 !#ifdef TSCSC
25527 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25528 !           evdw_p = evdw_p + evdwij
25529 !          ELSE
25530 !           evdw_m = evdw_m + evdwij
25531 !          END IF
25532 !#else
25533         evdw = evdw  &
25534             + evdwij
25535 !#endif
25536
25537         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25538         fac    = -expon * (c1 + evdwij) * rij_shift
25539         sigder = fac * sigder
25540 !          fac    = rij * fac
25541 ! Calculate distance derivative
25542         gg(1) =  fac
25543         gg(2) =  fac
25544         gg(3) =  fac
25545 !          if (b2.gt.0.0) then
25546         fac = chis1 * sqom1 + chis2 * sqom2 &
25547         - 2.0d0 * chis12 * om1 * om2 * om12
25548 ! we will use pom later in Gcav, so dont mess with it!
25549         pom = 1.0d0 - chis1 * chis2 * sqom12
25550         Lambf = (1.0d0 - (fac / pom))
25551 !          print *,"fac,pom",fac,pom,Lambf
25552         Lambf = dsqrt(Lambf)
25553         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25554 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25555 !       write (*,*) "sparrow = ", sparrow
25556         Chif = Rtail * sparrow
25557 !           print *,"rij,sparrow",rij , sparrow
25558         ChiLambf = Chif * Lambf
25559         eagle = dsqrt(ChiLambf)
25560         bat = ChiLambf ** 11.0d0
25561         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25562         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25563         botsq = bot * bot
25564 !          print *,top,bot,"bot,top",ChiLambf,Chif
25565         Fcav = top / bot
25566
25567        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25568        dbot = 12.0d0 * b4cav * bat * Lambf
25569        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25570
25571         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25572         dbot = 12.0d0 * b4cav * bat * Chif
25573         eagle = Lambf * pom
25574         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25575         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25576         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25577             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25578
25579         dFdL = ((dtop * bot - top * dbot) / botsq)
25580 !       dFdL = 0.0d0
25581         dCAVdOM1  = dFdL * ( dFdOM1 )
25582         dCAVdOM2  = dFdL * ( dFdOM2 )
25583         dCAVdOM12 = dFdL * ( dFdOM12 )
25584
25585        DO k= 1, 3
25586       ertail(k) = Rtail_distance(k)/Rtail
25587        END DO
25588        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25589        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25590        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25591        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25592        DO k = 1, 3
25593 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25594 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25595       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25596       gvdwx(k,i) = gvdwx(k,i) &
25597               - (( dFdR + gg(k) ) * pom)
25598 !c!     &             - ( dFdR * pom )
25599       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25600       gvdwx(k,j) = gvdwx(k,j)   &
25601               + (( dFdR + gg(k) ) * pom)
25602 !c!     &             + ( dFdR * pom )
25603
25604       gvdwc(k,i) = gvdwc(k,i)  &
25605               - (( dFdR + gg(k) ) * ertail(k))
25606 !c!     &             - ( dFdR * ertail(k))
25607
25608       gvdwc(k,j) = gvdwc(k,j) &
25609               + (( dFdR + gg(k) ) * ertail(k))
25610 !c!     &             + ( dFdR * ertail(k))
25611
25612       gg(k) = 0.0d0
25613 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25614 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25615       END DO
25616
25617
25618 !c! Compute head-head and head-tail energies for each state
25619
25620         isel = iabs(Qi) + iabs(Qj)
25621 ! double charge for Phophorylated! itype - 25,27,27
25622 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25623 !            Qi=Qi*2
25624 !            Qij=Qij*2
25625 !           endif
25626 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25627 !            Qj=Qj*2
25628 !            Qij=Qij*2
25629 !           endif
25630
25631 !          isel=0
25632         IF (isel.eq.0) THEN
25633 !c! No charges - do nothing
25634          eheadtail = 0.0d0
25635
25636         ELSE IF (isel.eq.4) THEN
25637 !c! Calculate dipole-dipole interactions
25638          CALL edd(ecl)
25639          eheadtail = ECL
25640 !           eheadtail = 0.0d0
25641
25642         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25643 !c! Charge-nonpolar interactions
25644         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25645           Qi=Qi*2
25646           Qij=Qij*2
25647          endif
25648         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25649           Qj=Qj*2
25650           Qij=Qij*2
25651          endif
25652
25653          CALL eqn(epol)
25654          eheadtail = epol
25655 !           eheadtail = 0.0d0
25656
25657         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25658 !c! Nonpolar-charge interactions
25659         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25660           Qi=Qi*2
25661           Qij=Qij*2
25662          endif
25663         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25664           Qj=Qj*2
25665           Qij=Qij*2
25666          endif
25667
25668          CALL enq(epol)
25669          eheadtail = epol
25670 !           eheadtail = 0.0d0
25671
25672         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25673 !c! Charge-dipole interactions
25674         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25675           Qi=Qi*2
25676           Qij=Qij*2
25677          endif
25678         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25679           Qj=Qj*2
25680           Qij=Qij*2
25681          endif
25682
25683          CALL eqd(ecl, elj, epol)
25684          eheadtail = ECL + elj + epol
25685 !           eheadtail = 0.0d0
25686
25687         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25688 !c! Dipole-charge interactions
25689         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25690           Qi=Qi*2
25691           Qij=Qij*2
25692          endif
25693         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25694           Qj=Qj*2
25695           Qij=Qij*2
25696          endif
25697          CALL edq(ecl, elj, epol)
25698         eheadtail = ECL + elj + epol
25699 !           eheadtail = 0.0d0
25700
25701         ELSE IF ((isel.eq.2.and.   &
25702              iabs(Qi).eq.1).and.  &
25703              nstate(itypi,itypj).eq.1) THEN
25704 !c! Same charge-charge interaction ( +/+ or -/- )
25705         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25706           Qi=Qi*2
25707           Qij=Qij*2
25708          endif
25709         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25710           Qj=Qj*2
25711           Qij=Qij*2
25712          endif
25713
25714          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25715          eheadtail = ECL + Egb + Epol + Fisocav + Elj
25716 !           eheadtail = 0.0d0
25717
25718         ELSE IF ((isel.eq.2.and.  &
25719              iabs(Qi).eq.1).and. &
25720              nstate(itypi,itypj).ne.1) THEN
25721 !c! Different charge-charge interaction ( +/- or -/+ )
25722         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25723           Qi=Qi*2
25724           Qij=Qij*2
25725          endif
25726         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25727           Qj=Qj*2
25728           Qij=Qij*2
25729          endif
25730
25731          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25732         END IF
25733        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25734       evdw = evdw  + Fcav + eheadtail
25735
25736        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25737       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25738       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25739       Equad,evdwij+Fcav+eheadtail,evdw
25740 !       evdw = evdw  + Fcav  + eheadtail
25741
25742       iF (nstate(itypi,itypj).eq.1) THEN
25743       CALL sc_grad
25744        END IF
25745 !c!-------------------------------------------------------------------
25746 !c! NAPISY KONCOWE
25747        END DO   ! j
25748       END DO    ! iint
25749        END DO     ! i
25750 !c      write (iout,*) "Number of loop steps in EGB:",ind
25751 !c      energy_dec=.false.
25752 !              print *,"EVDW KURW",evdw,nres
25753
25754        RETURN
25755       END SUBROUTINE emomo
25756 !C------------------------------------------------------------------------------------
25757       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25758       use calc_data
25759       use comm_momo
25760        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25761        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25762 !       integer :: k
25763 !c! Epol and Gpol analytical parameters
25764        alphapol1 = alphapol(itypi,itypj)
25765        alphapol2 = alphapol(itypj,itypi)
25766 !c! Fisocav and Gisocav analytical parameters
25767        al1  = alphiso(1,itypi,itypj)
25768        al2  = alphiso(2,itypi,itypj)
25769        al3  = alphiso(3,itypi,itypj)
25770        al4  = alphiso(4,itypi,itypj)
25771        csig = (1.0d0  &
25772          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25773          + sigiso2(itypi,itypj)**2.0d0))
25774 !c!
25775        pis  = sig0head(itypi,itypj)
25776        eps_head = epshead(itypi,itypj)
25777        Rhead_sq = Rhead * Rhead
25778 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25779 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25780        R1 = 0.0d0
25781        R2 = 0.0d0
25782        DO k = 1, 3
25783 !c! Calculate head-to-tail distances needed by Epol
25784       R1=R1+(ctail(k,2)-chead(k,1))**2
25785       R2=R2+(chead(k,2)-ctail(k,1))**2
25786        END DO
25787 !c! Pitagoras
25788        R1 = dsqrt(R1)
25789        R2 = dsqrt(R2)
25790
25791 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25792 !c!     &        +dhead(1,1,itypi,itypj))**2))
25793 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25794 !c!     &        +dhead(2,1,itypi,itypj))**2))
25795
25796 !c!-------------------------------------------------------------------
25797 !c! Coulomb electrostatic interaction
25798        Ecl = (332.0d0 * Qij) / Rhead
25799 !c! derivative of Ecl is Gcl...
25800        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25801        dGCLdOM1 = 0.0d0
25802        dGCLdOM2 = 0.0d0
25803        dGCLdOM12 = 0.0d0
25804        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25805        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25806        debkap=debaykap(itypi,itypj)
25807        Egb = -(332.0d0 * Qij *&
25808       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25809 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25810 !c! Derivative of Egb is Ggb...
25811        dGGBdFGB = -(-332.0d0 * Qij * &
25812        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25813        -(332.0d0 * Qij *&
25814       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25815        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25816        dGGBdR = dGGBdFGB * dFGBdR
25817 !c!-------------------------------------------------------------------
25818 !c! Fisocav - isotropic cavity creation term
25819 !c! or "how much energy it costs to put charged head in water"
25820        pom = Rhead * csig
25821        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25822        bot = (1.0d0 + al4 * pom**12.0d0)
25823        botsq = bot * bot
25824        FisoCav = top / bot
25825 !      write (*,*) "Rhead = ",Rhead
25826 !      write (*,*) "csig = ",csig
25827 !      write (*,*) "pom = ",pom
25828 !      write (*,*) "al1 = ",al1
25829 !      write (*,*) "al2 = ",al2
25830 !      write (*,*) "al3 = ",al3
25831 !      write (*,*) "al4 = ",al4
25832 !        write (*,*) "top = ",top
25833 !        write (*,*) "bot = ",bot
25834 !c! Derivative of Fisocav is GCV...
25835        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25836        dbot = 12.0d0 * al4 * pom ** 11.0d0
25837        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25838 !c!-------------------------------------------------------------------
25839 !c! Epol
25840 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25841        MomoFac1 = (1.0d0 - chi1 * sqom2)
25842        MomoFac2 = (1.0d0 - chi2 * sqom1)
25843        RR1  = ( R1 * R1 ) / MomoFac1
25844        RR2  = ( R2 * R2 ) / MomoFac2
25845        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25846        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25847        fgb1 = sqrt( RR1 + a12sq * ee1 )
25848        fgb2 = sqrt( RR2 + a12sq * ee2 )
25849        epol = 332.0d0 * eps_inout_fac * ( &
25850       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25851 !c!       epol = 0.0d0
25852        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25853              / (fgb1 ** 5.0d0)
25854        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25855              / (fgb2 ** 5.0d0)
25856        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25857            / ( 2.0d0 * fgb1 )
25858        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25859            / ( 2.0d0 * fgb2 )
25860        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25861             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25862        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25863             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25864        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25865 !c!       dPOLdR1 = 0.0d0
25866        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25867 !c!       dPOLdR2 = 0.0d0
25868        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25869 !c!       dPOLdOM1 = 0.0d0
25870        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25871 !c!       dPOLdOM2 = 0.0d0
25872 !c!-------------------------------------------------------------------
25873 !c! Elj
25874 !c! Lennard-Jones 6-12 interaction between heads
25875        pom = (pis / Rhead)**6.0d0
25876        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25877 !c! derivative of Elj is Glj
25878        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25879            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25880 !c!-------------------------------------------------------------------
25881 !c! Return the results
25882 !c! These things do the dRdX derivatives, that is
25883 !c! allow us to change what we see from function that changes with
25884 !c! distance to function that changes with LOCATION (of the interaction
25885 !c! site)
25886        DO k = 1, 3
25887       erhead(k) = Rhead_distance(k)/Rhead
25888       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25889       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25890        END DO
25891
25892        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25893        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25894        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25895        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25896        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25897        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25898        facd1 = d1 * vbld_inv(i+nres)
25899        facd2 = d2 * vbld_inv(j+nres)
25900        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25901        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25902
25903 !c! Now we add appropriate partial derivatives (one in each dimension)
25904        DO k = 1, 3
25905       hawk   = (erhead_tail(k,1) + &
25906       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25907       condor = (erhead_tail(k,2) + &
25908       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25909
25910       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25911       gvdwx(k,i) = gvdwx(k,i) &
25912               - dGCLdR * pom&
25913               - dGGBdR * pom&
25914               - dGCVdR * pom&
25915               - dPOLdR1 * hawk&
25916               - dPOLdR2 * (erhead_tail(k,2)&
25917       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25918               - dGLJdR * pom
25919
25920       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25921       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25922                + dGGBdR * pom+ dGCVdR * pom&
25923               + dPOLdR1 * (erhead_tail(k,1)&
25924       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25925               + dPOLdR2 * condor + dGLJdR * pom
25926
25927       gvdwc(k,i) = gvdwc(k,i)  &
25928               - dGCLdR * erhead(k)&
25929               - dGGBdR * erhead(k)&
25930               - dGCVdR * erhead(k)&
25931               - dPOLdR1 * erhead_tail(k,1)&
25932               - dPOLdR2 * erhead_tail(k,2)&
25933               - dGLJdR * erhead(k)
25934
25935       gvdwc(k,j) = gvdwc(k,j)         &
25936               + dGCLdR * erhead(k) &
25937               + dGGBdR * erhead(k) &
25938               + dGCVdR * erhead(k) &
25939               + dPOLdR1 * erhead_tail(k,1) &
25940               + dPOLdR2 * erhead_tail(k,2)&
25941               + dGLJdR * erhead(k)
25942
25943        END DO
25944        RETURN
25945       END SUBROUTINE eqq
25946
25947       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
25948       use calc_data
25949       use comm_momo
25950        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25951        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25952 !       integer :: k
25953 !c! Epol and Gpol analytical parameters
25954        alphapol1 = alphapolcat(itypi,itypj)
25955        alphapol2 = alphapolcat(itypj,itypi)
25956 !c! Fisocav and Gisocav analytical parameters
25957        al1  = alphisocat(1,itypi,itypj)
25958        al2  = alphisocat(2,itypi,itypj)
25959        al3  = alphisocat(3,itypi,itypj)
25960        al4  = alphisocat(4,itypi,itypj)
25961        csig = (1.0d0  &
25962          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
25963          + sigiso2cat(itypi,itypj)**2.0d0))
25964 !c!
25965        pis  = sig0headcat(itypi,itypj)
25966        eps_head = epsheadcat(itypi,itypj)
25967        Rhead_sq = Rhead * Rhead
25968 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25969 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25970        R1 = 0.0d0
25971        R2 = 0.0d0
25972        DO k = 1, 3
25973 !c! Calculate head-to-tail distances needed by Epol
25974       R1=R1+(ctail(k,2)-chead(k,1))**2
25975       R2=R2+(chead(k,2)-ctail(k,1))**2
25976        END DO
25977 !c! Pitagoras
25978        R1 = dsqrt(R1)
25979        R2 = dsqrt(R2)
25980
25981 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25982 !c!     &        +dhead(1,1,itypi,itypj))**2))
25983 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25984 !c!     &        +dhead(2,1,itypi,itypj))**2))
25985
25986 !c!-------------------------------------------------------------------
25987 !c! Coulomb electrostatic interaction
25988        Ecl = (332.0d0 * Qij) / Rhead
25989 !c! derivative of Ecl is Gcl...
25990        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25991        dGCLdOM1 = 0.0d0
25992        dGCLdOM2 = 0.0d0
25993        dGCLdOM12 = 0.0d0
25994        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25995        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25996        debkap=debaykapcat(itypi,itypj)
25997        Egb = -(332.0d0 * Qij *&
25998       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25999 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26000 !c! Derivative of Egb is Ggb...
26001        dGGBdFGB = -(-332.0d0 * Qij * &
26002        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26003        -(332.0d0 * Qij *&
26004       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26005        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26006        dGGBdR = dGGBdFGB * dFGBdR
26007 !c!-------------------------------------------------------------------
26008 !c! Fisocav - isotropic cavity creation term
26009 !c! or "how much energy it costs to put charged head in water"
26010        pom = Rhead * csig
26011        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26012        bot = (1.0d0 + al4 * pom**12.0d0)
26013        botsq = bot * bot
26014        FisoCav = top / bot
26015 !      write (*,*) "Rhead = ",Rhead
26016 !      write (*,*) "csig = ",csig
26017 !      write (*,*) "pom = ",pom
26018 !      write (*,*) "al1 = ",al1
26019 !      write (*,*) "al2 = ",al2
26020 !      write (*,*) "al3 = ",al3
26021 !      write (*,*) "al4 = ",al4
26022 !        write (*,*) "top = ",top
26023 !        write (*,*) "bot = ",bot
26024 !c! Derivative of Fisocav is GCV...
26025        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26026        dbot = 12.0d0 * al4 * pom ** 11.0d0
26027        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26028 !c!-------------------------------------------------------------------
26029 !c! Epol
26030 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26031        MomoFac1 = (1.0d0 - chi1 * sqom2)
26032        MomoFac2 = (1.0d0 - chi2 * sqom1)
26033        RR1  = ( R1 * R1 ) / MomoFac1
26034        RR2  = ( R2 * R2 ) / MomoFac2
26035        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26036        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26037        fgb1 = sqrt( RR1 + a12sq * ee1 )
26038        fgb2 = sqrt( RR2 + a12sq * ee2 )
26039        epol = 332.0d0 * eps_inout_fac * ( &
26040       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26041 !c!       epol = 0.0d0
26042        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26043              / (fgb1 ** 5.0d0)
26044        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26045              / (fgb2 ** 5.0d0)
26046        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26047            / ( 2.0d0 * fgb1 )
26048        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26049            / ( 2.0d0 * fgb2 )
26050        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26051             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26052        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26053             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26054        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26055 !c!       dPOLdR1 = 0.0d0
26056        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26057 !c!       dPOLdR2 = 0.0d0
26058        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26059 !c!       dPOLdOM1 = 0.0d0
26060        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26061 !c!       dPOLdOM2 = 0.0d0
26062 !c!-------------------------------------------------------------------
26063 !c! Elj
26064 !c! Lennard-Jones 6-12 interaction between heads
26065        pom = (pis / Rhead)**6.0d0
26066        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26067 !c! derivative of Elj is Glj
26068        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26069            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26070 !c!-------------------------------------------------------------------
26071 !c! Return the results
26072 !c! These things do the dRdX derivatives, that is
26073 !c! allow us to change what we see from function that changes with
26074 !c! distance to function that changes with LOCATION (of the interaction
26075 !c! site)
26076        DO k = 1, 3
26077       erhead(k) = Rhead_distance(k)/Rhead
26078       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26079       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26080        END DO
26081
26082        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26083        erdxj = scalar( erhead(1), dC_norm(1,j) )
26084        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26085        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26086        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26087        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26088        facd1 = d1 * vbld_inv(i+nres)
26089        facd2 = d2 * vbld_inv(j)
26090        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26091        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26092
26093 !c! Now we add appropriate partial derivatives (one in each dimension)
26094        DO k = 1, 3
26095       hawk   = (erhead_tail(k,1) + &
26096       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26097       condor = (erhead_tail(k,2) + &
26098       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26099
26100       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26101       gradpepcatx(k,i) = gradpepcatx(k,i) &
26102               - dGCLdR * pom&
26103               - dGGBdR * pom&
26104               - dGCVdR * pom&
26105               - dPOLdR1 * hawk&
26106               - dPOLdR2 * (erhead_tail(k,2)&
26107       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26108               - dGLJdR * pom
26109
26110       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26111 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26112 !                   + dGGBdR * pom+ dGCVdR * pom&
26113 !                  + dPOLdR1 * (erhead_tail(k,1)&
26114 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26115 !                  + dPOLdR2 * condor + dGLJdR * pom
26116
26117       gradpepcat(k,i) = gradpepcat(k,i)  &
26118               - dGCLdR * erhead(k)&
26119               - dGGBdR * erhead(k)&
26120               - dGCVdR * erhead(k)&
26121               - dPOLdR1 * erhead_tail(k,1)&
26122               - dPOLdR2 * erhead_tail(k,2)&
26123               - dGLJdR * erhead(k)
26124
26125       gradpepcat(k,j) = gradpepcat(k,j)         &
26126               + dGCLdR * erhead(k) &
26127               + dGGBdR * erhead(k) &
26128               + dGCVdR * erhead(k) &
26129               + dPOLdR1 * erhead_tail(k,1) &
26130               + dPOLdR2 * erhead_tail(k,2)&
26131               + dGLJdR * erhead(k)
26132
26133        END DO
26134        RETURN
26135       END SUBROUTINE eqq_cat
26136 !c!-------------------------------------------------------------------
26137       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26138       use comm_momo
26139       use calc_data
26140
26141        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26142        double precision ener(4)
26143        double precision dcosom1(3),dcosom2(3)
26144 !c! used in Epol derivatives
26145        double precision facd3, facd4
26146        double precision federmaus, adler
26147        integer istate,ii,jj
26148        real (kind=8) :: Fgb
26149 !       print *,"CALLING EQUAD"
26150 !c! Epol and Gpol analytical parameters
26151        alphapol1 = alphapol(itypi,itypj)
26152        alphapol2 = alphapol(itypj,itypi)
26153 !c! Fisocav and Gisocav analytical parameters
26154        al1  = alphiso(1,itypi,itypj)
26155        al2  = alphiso(2,itypi,itypj)
26156        al3  = alphiso(3,itypi,itypj)
26157        al4  = alphiso(4,itypi,itypj)
26158        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26159           + sigiso2(itypi,itypj)**2.0d0))
26160 !c!
26161        w1   = wqdip(1,itypi,itypj)
26162        w2   = wqdip(2,itypi,itypj)
26163        pis  = sig0head(itypi,itypj)
26164        eps_head = epshead(itypi,itypj)
26165 !c! First things first:
26166 !c! We need to do sc_grad's job with GB and Fcav
26167        eom1  = eps2der * eps2rt_om1 &
26168            - 2.0D0 * alf1 * eps3der&
26169            + sigder * sigsq_om1&
26170            + dCAVdOM1
26171        eom2  = eps2der * eps2rt_om2 &
26172            + 2.0D0 * alf2 * eps3der&
26173            + sigder * sigsq_om2&
26174            + dCAVdOM2
26175        eom12 =  evdwij  * eps1_om12 &
26176            + eps2der * eps2rt_om12 &
26177            - 2.0D0 * alf12 * eps3der&
26178            + sigder *sigsq_om12&
26179            + dCAVdOM12
26180 !c! now some magical transformations to project gradient into
26181 !c! three cartesian vectors
26182        DO k = 1, 3
26183       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26184       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26185       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26186 !c! this acts on hydrophobic center of interaction
26187       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26188               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26189               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26190       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26191               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26192               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26193 !c! this acts on Calpha
26194       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26195       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26196        END DO
26197 !c! sc_grad is done, now we will compute
26198        eheadtail = 0.0d0
26199        eom1 = 0.0d0
26200        eom2 = 0.0d0
26201        eom12 = 0.0d0
26202        DO istate = 1, nstate(itypi,itypj)
26203 !c*************************************************************
26204       IF (istate.ne.1) THEN
26205        IF (istate.lt.3) THEN
26206         ii = 1
26207        ELSE
26208         ii = 2
26209        END IF
26210       jj = istate/ii
26211       d1 = dhead(1,ii,itypi,itypj)
26212       d2 = dhead(2,jj,itypi,itypj)
26213       DO k = 1,3
26214        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26215        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26216        Rhead_distance(k) = chead(k,2) - chead(k,1)
26217       END DO
26218 !c! pitagoras (root of sum of squares)
26219       Rhead = dsqrt( &
26220              (Rhead_distance(1)*Rhead_distance(1))  &
26221            + (Rhead_distance(2)*Rhead_distance(2))  &
26222            + (Rhead_distance(3)*Rhead_distance(3)))
26223       END IF
26224       Rhead_sq = Rhead * Rhead
26225
26226 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26227 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26228       R1 = 0.0d0
26229       R2 = 0.0d0
26230       DO k = 1, 3
26231 !c! Calculate head-to-tail distances
26232        R1=R1+(ctail(k,2)-chead(k,1))**2
26233        R2=R2+(chead(k,2)-ctail(k,1))**2
26234       END DO
26235 !c! Pitagoras
26236       R1 = dsqrt(R1)
26237       R2 = dsqrt(R2)
26238       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26239 !c!        Ecl = 0.0d0
26240 !c!        write (*,*) "Ecl = ", Ecl
26241 !c! derivative of Ecl is Gcl...
26242       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26243 !c!        dGCLdR = 0.0d0
26244       dGCLdOM1 = 0.0d0
26245       dGCLdOM2 = 0.0d0
26246       dGCLdOM12 = 0.0d0
26247 !c!-------------------------------------------------------------------
26248 !c! Generalised Born Solvent Polarization
26249       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26250       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26251       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26252 !c!        Egb = 0.0d0
26253 !c!      write (*,*) "a1*a2 = ", a12sq
26254 !c!      write (*,*) "Rhead = ", Rhead
26255 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26256 !c!      write (*,*) "ee = ", ee
26257 !c!      write (*,*) "Fgb = ", Fgb
26258 !c!      write (*,*) "fac = ", eps_inout_fac
26259 !c!      write (*,*) "Qij = ", Qij
26260 !c!      write (*,*) "Egb = ", Egb
26261 !c! Derivative of Egb is Ggb...
26262 !c! dFGBdR is used by Quad's later...
26263       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26264       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26265              / ( 2.0d0 * Fgb )
26266       dGGBdR = dGGBdFGB * dFGBdR
26267 !c!        dGGBdR = 0.0d0
26268 !c!-------------------------------------------------------------------
26269 !c! Fisocav - isotropic cavity creation term
26270       pom = Rhead * csig
26271       top = al1 * (dsqrt(pom) + al2 * pom - al3)
26272       bot = (1.0d0 + al4 * pom**12.0d0)
26273       botsq = bot * bot
26274       FisoCav = top / bot
26275       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26276       dbot = 12.0d0 * al4 * pom ** 11.0d0
26277       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26278 !c!        dGCVdR = 0.0d0
26279 !c!-------------------------------------------------------------------
26280 !c! Polarization energy
26281 !c! Epol
26282       MomoFac1 = (1.0d0 - chi1 * sqom2)
26283       MomoFac2 = (1.0d0 - chi2 * sqom1)
26284       RR1  = ( R1 * R1 ) / MomoFac1
26285       RR2  = ( R2 * R2 ) / MomoFac2
26286       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26287       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26288       fgb1 = sqrt( RR1 + a12sq * ee1 )
26289       fgb2 = sqrt( RR2 + a12sq * ee2 )
26290       epol = 332.0d0 * eps_inout_fac * (&
26291       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26292 !c!        epol = 0.0d0
26293 !c! derivative of Epol is Gpol...
26294       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26295               / (fgb1 ** 5.0d0)
26296       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26297               / (fgb2 ** 5.0d0)
26298       dFGBdR1 = ( (R1 / MomoFac1) &
26299             * ( 2.0d0 - (0.5d0 * ee1) ) )&
26300             / ( 2.0d0 * fgb1 )
26301       dFGBdR2 = ( (R2 / MomoFac2) &
26302             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26303             / ( 2.0d0 * fgb2 )
26304       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26305              * ( 2.0d0 - 0.5d0 * ee1) ) &
26306              / ( 2.0d0 * fgb1 )
26307       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26308              * ( 2.0d0 - 0.5d0 * ee2) ) &
26309              / ( 2.0d0 * fgb2 )
26310       dPOLdR1 = dPOLdFGB1 * dFGBdR1
26311 !c!        dPOLdR1 = 0.0d0
26312       dPOLdR2 = dPOLdFGB2 * dFGBdR2
26313 !c!        dPOLdR2 = 0.0d0
26314       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26315 !c!        dPOLdOM1 = 0.0d0
26316       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26317       pom = (pis / Rhead)**6.0d0
26318       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26319 !c!        Elj = 0.0d0
26320 !c! derivative of Elj is Glj
26321       dGLJdR = 4.0d0 * eps_head &
26322           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26323           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26324 !c!        dGLJdR = 0.0d0
26325 !c!-------------------------------------------------------------------
26326 !c! Equad
26327        IF (Wqd.ne.0.0d0) THEN
26328       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26329            - 37.5d0  * ( sqom1 + sqom2 ) &
26330            + 157.5d0 * ( sqom1 * sqom2 ) &
26331            - 45.0d0  * om1*om2*om12
26332       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26333       Equad = fac * Beta1
26334 !c!        Equad = 0.0d0
26335 !c! derivative of Equad...
26336       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26337 !c!        dQUADdR = 0.0d0
26338       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26339 !c!        dQUADdOM1 = 0.0d0
26340       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26341 !c!        dQUADdOM2 = 0.0d0
26342       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26343        ELSE
26344        Beta1 = 0.0d0
26345        Equad = 0.0d0
26346       END IF
26347 !c!-------------------------------------------------------------------
26348 !c! Return the results
26349 !c! Angular stuff
26350       eom1 = dPOLdOM1 + dQUADdOM1
26351       eom2 = dPOLdOM2 + dQUADdOM2
26352       eom12 = dQUADdOM12
26353 !c! now some magical transformations to project gradient into
26354 !c! three cartesian vectors
26355       DO k = 1, 3
26356        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26357        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26358        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26359       END DO
26360 !c! Radial stuff
26361       DO k = 1, 3
26362        erhead(k) = Rhead_distance(k)/Rhead
26363        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26364        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26365       END DO
26366       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26367       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26368       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26369       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26370       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26371       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26372       facd1 = d1 * vbld_inv(i+nres)
26373       facd2 = d2 * vbld_inv(j+nres)
26374       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26375       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26376       DO k = 1, 3
26377        hawk   = erhead_tail(k,1) + &
26378        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26379        condor = erhead_tail(k,2) + &
26380        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26381
26382        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26383 !c! this acts on hydrophobic center of interaction
26384        gheadtail(k,1,1) = gheadtail(k,1,1) &
26385                    - dGCLdR * pom &
26386                    - dGGBdR * pom &
26387                    - dGCVdR * pom &
26388                    - dPOLdR1 * hawk &
26389                    - dPOLdR2 * (erhead_tail(k,2) &
26390       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26391                    - dGLJdR * pom &
26392                    - dQUADdR * pom&
26393                    - tuna(k) &
26394              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26395              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26396
26397        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26398 !c! this acts on hydrophobic center of interaction
26399        gheadtail(k,2,1) = gheadtail(k,2,1)  &
26400                    + dGCLdR * pom      &
26401                    + dGGBdR * pom      &
26402                    + dGCVdR * pom      &
26403                    + dPOLdR1 * (erhead_tail(k,1) &
26404       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26405                    + dPOLdR2 * condor &
26406                    + dGLJdR * pom &
26407                    + dQUADdR * pom &
26408                    + tuna(k) &
26409              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26410              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26411
26412 !c! this acts on Calpha
26413        gheadtail(k,3,1) = gheadtail(k,3,1)  &
26414                    - dGCLdR * erhead(k)&
26415                    - dGGBdR * erhead(k)&
26416                    - dGCVdR * erhead(k)&
26417                    - dPOLdR1 * erhead_tail(k,1)&
26418                    - dPOLdR2 * erhead_tail(k,2)&
26419                    - dGLJdR * erhead(k) &
26420                    - dQUADdR * erhead(k)&
26421                    - tuna(k)
26422 !c! this acts on Calpha
26423        gheadtail(k,4,1) = gheadtail(k,4,1)   &
26424                     + dGCLdR * erhead(k) &
26425                     + dGGBdR * erhead(k) &
26426                     + dGCVdR * erhead(k) &
26427                     + dPOLdR1 * erhead_tail(k,1) &
26428                     + dPOLdR2 * erhead_tail(k,2) &
26429                     + dGLJdR * erhead(k) &
26430                     + dQUADdR * erhead(k)&
26431                     + tuna(k)
26432       END DO
26433       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26434       eheadtail = eheadtail &
26435               + wstate(istate, itypi, itypj) &
26436               * dexp(-betaT * ener(istate))
26437 !c! foreach cartesian dimension
26438       DO k = 1, 3
26439 !c! foreach of two gvdwx and gvdwc
26440        DO l = 1, 4
26441         gheadtail(k,l,2) = gheadtail(k,l,2)  &
26442                      + wstate( istate, itypi, itypj ) &
26443                      * dexp(-betaT * ener(istate)) &
26444                      * gheadtail(k,l,1)
26445         gheadtail(k,l,1) = 0.0d0
26446        END DO
26447       END DO
26448        END DO
26449 !c! Here ended the gigantic DO istate = 1, 4, which starts
26450 !c! at the beggining of the subroutine
26451
26452        DO k = 1, 3
26453       DO l = 1, 4
26454        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26455       END DO
26456       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26457       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26458       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26459       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26460       DO l = 1, 4
26461        gheadtail(k,l,1) = 0.0d0
26462        gheadtail(k,l,2) = 0.0d0
26463       END DO
26464        END DO
26465        eheadtail = (-dlog(eheadtail)) / betaT
26466        dPOLdOM1 = 0.0d0
26467        dPOLdOM2 = 0.0d0
26468        dQUADdOM1 = 0.0d0
26469        dQUADdOM2 = 0.0d0
26470        dQUADdOM12 = 0.0d0
26471        RETURN
26472       END SUBROUTINE energy_quad
26473 !!-----------------------------------------------------------
26474       SUBROUTINE eqn(Epol)
26475       use comm_momo
26476       use calc_data
26477
26478       double precision  facd4, federmaus,epol
26479       alphapol1 = alphapol(itypi,itypj)
26480 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26481        R1 = 0.0d0
26482        DO k = 1, 3
26483 !c! Calculate head-to-tail distances
26484       R1=R1+(ctail(k,2)-chead(k,1))**2
26485        END DO
26486 !c! Pitagoras
26487        R1 = dsqrt(R1)
26488
26489 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26490 !c!     &        +dhead(1,1,itypi,itypj))**2))
26491 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26492 !c!     &        +dhead(2,1,itypi,itypj))**2))
26493 !c--------------------------------------------------------------------
26494 !c Polarization energy
26495 !c Epol
26496        MomoFac1 = (1.0d0 - chi1 * sqom2)
26497        RR1  = R1 * R1 / MomoFac1
26498        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26499        fgb1 = sqrt( RR1 + a12sq * ee1)
26500        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26501        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26502              / (fgb1 ** 5.0d0)
26503        dFGBdR1 = ( (R1 / MomoFac1) &
26504             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26505             / ( 2.0d0 * fgb1 )
26506        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26507             * (2.0d0 - 0.5d0 * ee1) ) &
26508             / (2.0d0 * fgb1)
26509        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26510 !c!       dPOLdR1 = 0.0d0
26511        dPOLdOM1 = 0.0d0
26512        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26513        DO k = 1, 3
26514       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26515        END DO
26516        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26517        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26518        facd1 = d1 * vbld_inv(i+nres)
26519        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26520
26521        DO k = 1, 3
26522       hawk = (erhead_tail(k,1) + &
26523       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26524
26525       gvdwx(k,i) = gvdwx(k,i) &
26526                - dPOLdR1 * hawk
26527       gvdwx(k,j) = gvdwx(k,j) &
26528                + dPOLdR1 * (erhead_tail(k,1) &
26529        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26530
26531       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26532       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26533
26534        END DO
26535        RETURN
26536       END SUBROUTINE eqn
26537       SUBROUTINE enq(Epol)
26538       use calc_data
26539       use comm_momo
26540        double precision facd3, adler,epol
26541        alphapol2 = alphapol(itypj,itypi)
26542 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26543        R2 = 0.0d0
26544        DO k = 1, 3
26545 !c! Calculate head-to-tail distances
26546       R2=R2+(chead(k,2)-ctail(k,1))**2
26547        END DO
26548 !c! Pitagoras
26549        R2 = dsqrt(R2)
26550
26551 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26552 !c!     &        +dhead(1,1,itypi,itypj))**2))
26553 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26554 !c!     &        +dhead(2,1,itypi,itypj))**2))
26555 !c------------------------------------------------------------------------
26556 !c Polarization energy
26557        MomoFac2 = (1.0d0 - chi2 * sqom1)
26558        RR2  = R2 * R2 / MomoFac2
26559        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26560        fgb2 = sqrt(RR2  + a12sq * ee2)
26561        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26562        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26563             / (fgb2 ** 5.0d0)
26564        dFGBdR2 = ( (R2 / MomoFac2)  &
26565             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26566             / (2.0d0 * fgb2)
26567        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26568             * (2.0d0 - 0.5d0 * ee2) ) &
26569             / (2.0d0 * fgb2)
26570        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26571 !c!       dPOLdR2 = 0.0d0
26572        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26573 !c!       dPOLdOM1 = 0.0d0
26574        dPOLdOM2 = 0.0d0
26575 !c!-------------------------------------------------------------------
26576 !c! Return the results
26577 !c! (See comments in Eqq)
26578        DO k = 1, 3
26579       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26580        END DO
26581        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26582        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26583        facd2 = d2 * vbld_inv(j+nres)
26584        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26585        DO k = 1, 3
26586       condor = (erhead_tail(k,2) &
26587        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26588
26589       gvdwx(k,i) = gvdwx(k,i) &
26590                - dPOLdR2 * (erhead_tail(k,2) &
26591        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26592       gvdwx(k,j) = gvdwx(k,j)   &
26593                + dPOLdR2 * condor
26594
26595       gvdwc(k,i) = gvdwc(k,i) &
26596                - dPOLdR2 * erhead_tail(k,2)
26597       gvdwc(k,j) = gvdwc(k,j) &
26598                + dPOLdR2 * erhead_tail(k,2)
26599
26600        END DO
26601       RETURN
26602       END SUBROUTINE enq
26603
26604       SUBROUTINE enq_cat(Epol)
26605       use calc_data
26606       use comm_momo
26607        double precision facd3, adler,epol
26608        alphapol2 = alphapolcat(itypj,itypi)
26609 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26610        R2 = 0.0d0
26611        DO k = 1, 3
26612 !c! Calculate head-to-tail distances
26613       R2=R2+(chead(k,2)-ctail(k,1))**2
26614        END DO
26615 !c! Pitagoras
26616        R2 = dsqrt(R2)
26617
26618 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26619 !c!     &        +dhead(1,1,itypi,itypj))**2))
26620 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26621 !c!     &        +dhead(2,1,itypi,itypj))**2))
26622 !c------------------------------------------------------------------------
26623 !c Polarization energy
26624        MomoFac2 = (1.0d0 - chi2 * sqom1)
26625        RR2  = R2 * R2 / MomoFac2
26626        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26627        fgb2 = sqrt(RR2  + a12sq * ee2)
26628        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26629        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26630             / (fgb2 ** 5.0d0)
26631        dFGBdR2 = ( (R2 / MomoFac2)  &
26632             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26633             / (2.0d0 * fgb2)
26634        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26635             * (2.0d0 - 0.5d0 * ee2) ) &
26636             / (2.0d0 * fgb2)
26637        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26638 !c!       dPOLdR2 = 0.0d0
26639        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26640 !c!       dPOLdOM1 = 0.0d0
26641        dPOLdOM2 = 0.0d0
26642
26643 !c!-------------------------------------------------------------------
26644 !c! Return the results
26645 !c! (See comments in Eqq)
26646        DO k = 1, 3
26647       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26648        END DO
26649        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26650        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26651        facd2 = d2 * vbld_inv(j+nres)
26652        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26653        DO k = 1, 3
26654       condor = (erhead_tail(k,2) &
26655        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26656
26657       gradpepcatx(k,i) = gradpepcatx(k,i) &
26658                - dPOLdR2 * (erhead_tail(k,2) &
26659        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26660 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
26661 !                   + dPOLdR2 * condor
26662
26663       gradpepcat(k,i) = gradpepcat(k,i) &
26664                - dPOLdR2 * erhead_tail(k,2)
26665       gradpepcat(k,j) = gradpepcat(k,j) &
26666                + dPOLdR2 * erhead_tail(k,2)
26667
26668        END DO
26669       RETURN
26670       END SUBROUTINE enq_cat
26671
26672       SUBROUTINE eqd(Ecl,Elj,Epol)
26673       use calc_data
26674       use comm_momo
26675        double precision  facd4, federmaus,ecl,elj,epol
26676        alphapol1 = alphapol(itypi,itypj)
26677        w1        = wqdip(1,itypi,itypj)
26678        w2        = wqdip(2,itypi,itypj)
26679        pis       = sig0head(itypi,itypj)
26680        eps_head   = epshead(itypi,itypj)
26681 !c!-------------------------------------------------------------------
26682 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26683        R1 = 0.0d0
26684        DO k = 1, 3
26685 !c! Calculate head-to-tail distances
26686       R1=R1+(ctail(k,2)-chead(k,1))**2
26687        END DO
26688 !c! Pitagoras
26689        R1 = dsqrt(R1)
26690
26691 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26692 !c!     &        +dhead(1,1,itypi,itypj))**2))
26693 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26694 !c!     &        +dhead(2,1,itypi,itypj))**2))
26695
26696 !c!-------------------------------------------------------------------
26697 !c! ecl
26698        sparrow  = w1 * Qi * om1
26699        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26700        Ecl = sparrow / Rhead**2.0d0 &
26701          - hawk    / Rhead**4.0d0
26702        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26703              + 4.0d0 * hawk    / Rhead**5.0d0
26704 !c! dF/dom1
26705        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26706 !c! dF/dom2
26707        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26708 !c--------------------------------------------------------------------
26709 !c Polarization energy
26710 !c Epol
26711        MomoFac1 = (1.0d0 - chi1 * sqom2)
26712        RR1  = R1 * R1 / MomoFac1
26713        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26714        fgb1 = sqrt( RR1 + a12sq * ee1)
26715        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26716 !c!       epol = 0.0d0
26717 !c!------------------------------------------------------------------
26718 !c! derivative of Epol is Gpol...
26719        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26720              / (fgb1 ** 5.0d0)
26721        dFGBdR1 = ( (R1 / MomoFac1)  &
26722            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26723            / ( 2.0d0 * fgb1 )
26724        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26725              * (2.0d0 - 0.5d0 * ee1) ) &
26726              / (2.0d0 * fgb1)
26727        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26728 !c!       dPOLdR1 = 0.0d0
26729        dPOLdOM1 = 0.0d0
26730        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26731 !c!       dPOLdOM2 = 0.0d0
26732 !c!-------------------------------------------------------------------
26733 !c! Elj
26734        pom = (pis / Rhead)**6.0d0
26735        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26736 !c! derivative of Elj is Glj
26737        dGLJdR = 4.0d0 * eps_head &
26738         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26739         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26740        DO k = 1, 3
26741       erhead(k) = Rhead_distance(k)/Rhead
26742       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26743        END DO
26744
26745        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26746        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26747        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26748        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26749        facd1 = d1 * vbld_inv(i+nres)
26750        facd2 = d2 * vbld_inv(j+nres)
26751        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26752
26753        DO k = 1, 3
26754       hawk = (erhead_tail(k,1) +  &
26755       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26756
26757       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26758       gvdwx(k,i) = gvdwx(k,i)  &
26759                - dGCLdR * pom&
26760                - dPOLdR1 * hawk &
26761                - dGLJdR * pom
26762
26763       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26764       gvdwx(k,j) = gvdwx(k,j)    &
26765                + dGCLdR * pom  &
26766                + dPOLdR1 * (erhead_tail(k,1) &
26767        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26768                + dGLJdR * pom
26769
26770
26771       gvdwc(k,i) = gvdwc(k,i)          &
26772                - dGCLdR * erhead(k)  &
26773                - dPOLdR1 * erhead_tail(k,1) &
26774                - dGLJdR * erhead(k)
26775
26776       gvdwc(k,j) = gvdwc(k,j)          &
26777                + dGCLdR * erhead(k)  &
26778                + dPOLdR1 * erhead_tail(k,1) &
26779                + dGLJdR * erhead(k)
26780
26781        END DO
26782        RETURN
26783       END SUBROUTINE eqd
26784       SUBROUTINE edq(Ecl,Elj,Epol)
26785 !       IMPLICIT NONE
26786        use comm_momo
26787       use calc_data
26788
26789       double precision  facd3, adler,ecl,elj,epol
26790        alphapol2 = alphapol(itypj,itypi)
26791        w1        = wqdip(1,itypi,itypj)
26792        w2        = wqdip(2,itypi,itypj)
26793        pis       = sig0head(itypi,itypj)
26794        eps_head  = epshead(itypi,itypj)
26795 !c!-------------------------------------------------------------------
26796 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26797        R2 = 0.0d0
26798        DO k = 1, 3
26799 !c! Calculate head-to-tail distances
26800       R2=R2+(chead(k,2)-ctail(k,1))**2
26801        END DO
26802 !c! Pitagoras
26803        R2 = dsqrt(R2)
26804
26805 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26806 !c!     &        +dhead(1,1,itypi,itypj))**2))
26807 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26808 !c!     &        +dhead(2,1,itypi,itypj))**2))
26809
26810
26811 !c!-------------------------------------------------------------------
26812 !c! ecl
26813        sparrow  = w1 * Qj * om1
26814        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26815        ECL = sparrow / Rhead**2.0d0 &
26816          - hawk    / Rhead**4.0d0
26817 !c!-------------------------------------------------------------------
26818 !c! derivative of ecl is Gcl
26819 !c! dF/dr part
26820        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26821              + 4.0d0 * hawk    / Rhead**5.0d0
26822 !c! dF/dom1
26823        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26824 !c! dF/dom2
26825        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26826 !c--------------------------------------------------------------------
26827 !c Polarization energy
26828 !c Epol
26829        MomoFac2 = (1.0d0 - chi2 * sqom1)
26830        RR2  = R2 * R2 / MomoFac2
26831        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26832        fgb2 = sqrt(RR2  + a12sq * ee2)
26833        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26834        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26835              / (fgb2 ** 5.0d0)
26836        dFGBdR2 = ( (R2 / MomoFac2)  &
26837              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26838              / (2.0d0 * fgb2)
26839        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26840             * (2.0d0 - 0.5d0 * ee2) ) &
26841             / (2.0d0 * fgb2)
26842        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26843 !c!       dPOLdR2 = 0.0d0
26844        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26845 !c!       dPOLdOM1 = 0.0d0
26846        dPOLdOM2 = 0.0d0
26847 !c!-------------------------------------------------------------------
26848 !c! Elj
26849        pom = (pis / Rhead)**6.0d0
26850        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26851 !c! derivative of Elj is Glj
26852        dGLJdR = 4.0d0 * eps_head &
26853          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26854          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26855 !c!-------------------------------------------------------------------
26856 !c! Return the results
26857 !c! (see comments in Eqq)
26858        DO k = 1, 3
26859       erhead(k) = Rhead_distance(k)/Rhead
26860       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26861        END DO
26862        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26863        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26864        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26865        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26866        facd1 = d1 * vbld_inv(i+nres)
26867        facd2 = d2 * vbld_inv(j+nres)
26868        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26869        DO k = 1, 3
26870       condor = (erhead_tail(k,2) &
26871        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26872
26873       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26874       gvdwx(k,i) = gvdwx(k,i) &
26875               - dGCLdR * pom &
26876               - dPOLdR2 * (erhead_tail(k,2) &
26877        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26878               - dGLJdR * pom
26879
26880       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26881       gvdwx(k,j) = gvdwx(k,j) &
26882               + dGCLdR * pom &
26883               + dPOLdR2 * condor &
26884               + dGLJdR * pom
26885
26886
26887       gvdwc(k,i) = gvdwc(k,i) &
26888               - dGCLdR * erhead(k) &
26889               - dPOLdR2 * erhead_tail(k,2) &
26890               - dGLJdR * erhead(k)
26891
26892       gvdwc(k,j) = gvdwc(k,j) &
26893               + dGCLdR * erhead(k) &
26894               + dPOLdR2 * erhead_tail(k,2) &
26895               + dGLJdR * erhead(k)
26896
26897        END DO
26898        RETURN
26899       END SUBROUTINE edq
26900
26901       SUBROUTINE edq_cat(Ecl,Elj,Epol)
26902       use comm_momo
26903       use calc_data
26904
26905       double precision  facd3, adler,ecl,elj,epol
26906        alphapol2 = alphapolcat(itypj,itypi)
26907        w1        = wqdipcat(1,itypi,itypj)
26908        w2        = wqdipcat(2,itypi,itypj)
26909        pis       = sig0headcat(itypi,itypj)
26910        eps_head  = epsheadcat(itypi,itypj)
26911 !c!-------------------------------------------------------------------
26912 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26913        R2 = 0.0d0
26914        DO k = 1, 3
26915 !c! Calculate head-to-tail distances
26916       R2=R2+(chead(k,2)-ctail(k,1))**2
26917        END DO
26918 !c! Pitagoras
26919        R2 = dsqrt(R2)
26920
26921 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26922 !c!     &        +dhead(1,1,itypi,itypj))**2))
26923 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26924 !c!     &        +dhead(2,1,itypi,itypj))**2))
26925
26926
26927 !c!-------------------------------------------------------------------
26928 !c! ecl
26929 !       write(iout,*) "KURWA2",Rhead
26930        sparrow  = w1 * Qj * om1
26931        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26932        ECL = sparrow / Rhead**2.0d0 &
26933          - hawk    / Rhead**4.0d0
26934 !c!-------------------------------------------------------------------
26935 !c! derivative of ecl is Gcl
26936 !c! dF/dr part
26937        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26938              + 4.0d0 * hawk    / Rhead**5.0d0
26939 !c! dF/dom1
26940        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26941 !c! dF/dom2
26942        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26943 !c--------------------------------------------------------------------
26944 !c--------------------------------------------------------------------
26945 !c Polarization energy
26946 !c Epol
26947        MomoFac2 = (1.0d0 - chi2 * sqom1)
26948        RR2  = R2 * R2 / MomoFac2
26949        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26950        fgb2 = sqrt(RR2  + a12sq * ee2)
26951        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26952        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26953              / (fgb2 ** 5.0d0)
26954        dFGBdR2 = ( (R2 / MomoFac2)  &
26955              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26956              / (2.0d0 * fgb2)
26957        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26958             * (2.0d0 - 0.5d0 * ee2) ) &
26959             / (2.0d0 * fgb2)
26960        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26961 !c!       dPOLdR2 = 0.0d0
26962        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26963 !c!       dPOLdOM1 = 0.0d0
26964        dPOLdOM2 = 0.0d0
26965 !c!-------------------------------------------------------------------
26966 !c! Elj
26967        pom = (pis / Rhead)**6.0d0
26968        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26969 !c! derivative of Elj is Glj
26970        dGLJdR = 4.0d0 * eps_head &
26971          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26972          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26973 !c!-------------------------------------------------------------------
26974
26975 !c! Return the results
26976 !c! (see comments in Eqq)
26977        DO k = 1, 3
26978       erhead(k) = Rhead_distance(k)/Rhead
26979       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26980        END DO
26981        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26982        erdxj = scalar( erhead(1), dC_norm(1,j) )
26983        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26984        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26985        facd1 = d1 * vbld_inv(i+nres)
26986        facd2 = d2 * vbld_inv(j)
26987        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26988        DO k = 1, 3
26989       condor = (erhead_tail(k,2) &
26990        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26991
26992       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26993       gradpepcatx(k,i) = gradpepcatx(k,i) &
26994               - dGCLdR * pom &
26995               - dPOLdR2 * (erhead_tail(k,2) &
26996        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26997               - dGLJdR * pom
26998
26999       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27000 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27001 !                  + dGCLdR * pom &
27002 !                  + dPOLdR2 * condor &
27003 !                  + dGLJdR * pom
27004
27005
27006       gradpepcat(k,i) = gradpepcat(k,i) &
27007               - dGCLdR * erhead(k) &
27008               - dPOLdR2 * erhead_tail(k,2) &
27009               - dGLJdR * erhead(k)
27010
27011       gradpepcat(k,j) = gradpepcat(k,j) &
27012               + dGCLdR * erhead(k) &
27013               + dPOLdR2 * erhead_tail(k,2) &
27014               + dGLJdR * erhead(k)
27015
27016        END DO
27017        RETURN
27018       END SUBROUTINE edq_cat
27019
27020       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27021       use comm_momo
27022       use calc_data
27023
27024       double precision  facd3, adler,ecl,elj,epol
27025        alphapol2 = alphapolcat(itypj,itypi)
27026        w1        = wqdipcat(1,itypi,itypj)
27027        w2        = wqdipcat(2,itypi,itypj)
27028        pis       = sig0headcat(itypi,itypj)
27029        eps_head  = epsheadcat(itypi,itypj)
27030 !c!-------------------------------------------------------------------
27031 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27032        R2 = 0.0d0
27033        DO k = 1, 3
27034 !c! Calculate head-to-tail distances
27035       R2=R2+(chead(k,2)-ctail(k,1))**2
27036        END DO
27037 !c! Pitagoras
27038        R2 = dsqrt(R2)
27039
27040 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27041 !c!     &        +dhead(1,1,itypi,itypj))**2))
27042 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27043 !c!     &        +dhead(2,1,itypi,itypj))**2))
27044
27045
27046 !c!-------------------------------------------------------------------
27047 !c! ecl
27048        sparrow  = w1 * Qj * om1
27049        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27050 !       print *,"CO2", itypi,itypj
27051 !       print *,"CO?!.", w1,w2,Qj,om1
27052        ECL = sparrow / Rhead**2.0d0 &
27053          - hawk    / Rhead**4.0d0
27054 !c!-------------------------------------------------------------------
27055 !c! derivative of ecl is Gcl
27056 !c! dF/dr part
27057        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27058              + 4.0d0 * hawk    / Rhead**5.0d0
27059 !c! dF/dom1
27060        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27061 !c! dF/dom2
27062        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27063 !c--------------------------------------------------------------------
27064 !c--------------------------------------------------------------------
27065 !c Polarization energy
27066 !c Epol
27067        MomoFac2 = (1.0d0 - chi2 * sqom1)
27068        RR2  = R2 * R2 / MomoFac2
27069        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27070        fgb2 = sqrt(RR2  + a12sq * ee2)
27071        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27072        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27073              / (fgb2 ** 5.0d0)
27074        dFGBdR2 = ( (R2 / MomoFac2)  &
27075              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27076              / (2.0d0 * fgb2)
27077        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27078             * (2.0d0 - 0.5d0 * ee2) ) &
27079             / (2.0d0 * fgb2)
27080        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27081 !c!       dPOLdR2 = 0.0d0
27082        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27083 !c!       dPOLdOM1 = 0.0d0
27084        dPOLdOM2 = 0.0d0
27085 !c!-------------------------------------------------------------------
27086 !c! Elj
27087        pom = (pis / Rhead)**6.0d0
27088        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27089 !c! derivative of Elj is Glj
27090        dGLJdR = 4.0d0 * eps_head &
27091          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27092          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27093 !c!-------------------------------------------------------------------
27094
27095 !c! Return the results
27096 !c! (see comments in Eqq)
27097        DO k = 1, 3
27098       erhead(k) = Rhead_distance(k)/Rhead
27099       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27100        END DO
27101        erdxi = scalar( erhead(1), dC_norm(1,i) )
27102        erdxj = scalar( erhead(1), dC_norm(1,j) )
27103        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27104        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27105        facd1 = d1 * vbld_inv(i+1)/2.0
27106        facd2 = d2 * vbld_inv(j)
27107        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27108        DO k = 1, 3
27109       condor = (erhead_tail(k,2) &
27110        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27111
27112       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27113 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27114 !                  - dGCLdR * pom &
27115 !                  - dPOLdR2 * (erhead_tail(k,2) &
27116 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27117 !                  - dGLJdR * pom
27118
27119       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27120 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27121 !                  + dGCLdR * pom &
27122 !                  + dPOLdR2 * condor &
27123 !                  + dGLJdR * pom
27124
27125
27126       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27127               - dGCLdR * erhead(k) &
27128               - dPOLdR2 * erhead_tail(k,2) &
27129               - dGLJdR * erhead(k))
27130       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27131               - dGCLdR * erhead(k) &
27132               - dPOLdR2 * erhead_tail(k,2) &
27133               - dGLJdR * erhead(k))
27134
27135
27136       gradpepcat(k,j) = gradpepcat(k,j) &
27137               + dGCLdR * erhead(k) &
27138               + dPOLdR2 * erhead_tail(k,2) &
27139               + dGLJdR * erhead(k)
27140
27141        END DO
27142        RETURN
27143       END SUBROUTINE edq_cat_pep
27144
27145       SUBROUTINE edd(ECL)
27146 !       IMPLICIT NONE
27147        use comm_momo
27148       use calc_data
27149
27150        double precision ecl
27151 !c!       csig = sigiso(itypi,itypj)
27152        w1 = wqdip(1,itypi,itypj)
27153        w2 = wqdip(2,itypi,itypj)
27154 !c!-------------------------------------------------------------------
27155 !c! ECL
27156        fac = (om12 - 3.0d0 * om1 * om2)
27157        c1 = (w1 / (Rhead**3.0d0)) * fac
27158        c2 = (w2 / Rhead ** 6.0d0) &
27159         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27160        ECL = c1 - c2
27161 !c!       write (*,*) "w1 = ", w1
27162 !c!       write (*,*) "w2 = ", w2
27163 !c!       write (*,*) "om1 = ", om1
27164 !c!       write (*,*) "om2 = ", om2
27165 !c!       write (*,*) "om12 = ", om12
27166 !c!       write (*,*) "fac = ", fac
27167 !c!       write (*,*) "c1 = ", c1
27168 !c!       write (*,*) "c2 = ", c2
27169 !c!       write (*,*) "Ecl = ", Ecl
27170 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27171 !c!       write (*,*) "c2_2 = ",
27172 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27173 !c!-------------------------------------------------------------------
27174 !c! dervative of ECL is GCL...
27175 !c! dECL/dr
27176        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27177        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27178         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27179        dGCLdR = c1 - c2
27180 !c! dECL/dom1
27181        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27182        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27183         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27184        dGCLdOM1 = c1 - c2
27185 !c! dECL/dom2
27186        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27187        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27188         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27189        dGCLdOM2 = c1 - c2
27190 !c! dECL/dom12
27191        c1 = w1 / (Rhead ** 3.0d0)
27192        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27193        dGCLdOM12 = c1 - c2
27194 !c!-------------------------------------------------------------------
27195 !c! Return the results
27196 !c! (see comments in Eqq)
27197        DO k= 1, 3
27198       erhead(k) = Rhead_distance(k)/Rhead
27199        END DO
27200        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27201        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27202        facd1 = d1 * vbld_inv(i+nres)
27203        facd2 = d2 * vbld_inv(j+nres)
27204        DO k = 1, 3
27205
27206       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27207       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27208       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27209       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27210
27211       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27212       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27213        END DO
27214        RETURN
27215       END SUBROUTINE edd
27216       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27217 !       IMPLICIT NONE
27218        use comm_momo
27219       use calc_data
27220
27221        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27222        eps_out=80.0d0
27223        itypi = itype(i,1)
27224        itypj = itype(j,1)
27225 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27226 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27227 !c!       t_bath = 300
27228 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27229        Rb=0.001986d0
27230        BetaT = 1.0d0 / (298.0d0 * Rb)
27231 !c! Gay-berne var's
27232        sig0ij = sigma( itypi,itypj )
27233        chi1   = chi( itypi, itypj )
27234        chi2   = chi( itypj, itypi )
27235        chi12  = chi1 * chi2
27236        chip1  = chipp( itypi, itypj )
27237        chip2  = chipp( itypj, itypi )
27238        chip12 = chip1 * chip2
27239 !       chi1=0.0
27240 !       chi2=0.0
27241 !       chi12=0.0
27242 !       chip1=0.0
27243 !       chip2=0.0
27244 !       chip12=0.0
27245 !c! not used by momo potential, but needed by sc_angular which is shared
27246 !c! by all energy_potential subroutines
27247        alf1   = 0.0d0
27248        alf2   = 0.0d0
27249        alf12  = 0.0d0
27250 !c! location, location, location
27251 !       xj  = c( 1, nres+j ) - xi
27252 !       yj  = c( 2, nres+j ) - yi
27253 !       zj  = c( 3, nres+j ) - zi
27254        dxj = dc_norm( 1, nres+j )
27255        dyj = dc_norm( 2, nres+j )
27256        dzj = dc_norm( 3, nres+j )
27257 !c! distance from center of chain(?) to polar/charged head
27258 !c!       write (*,*) "istate = ", 1
27259 !c!       write (*,*) "ii = ", 1
27260 !c!       write (*,*) "jj = ", 1
27261        d1 = dhead(1, 1, itypi, itypj)
27262        d2 = dhead(2, 1, itypi, itypj)
27263 !c! ai*aj from Fgb
27264        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27265 !c!       a12sq = a12sq * a12sq
27266 !c! charge of amino acid itypi is...
27267        Qi  = icharge(itypi)
27268        Qj  = icharge(itypj)
27269        Qij = Qi * Qj
27270 !c! chis1,2,12
27271        chis1 = chis(itypi,itypj)
27272        chis2 = chis(itypj,itypi)
27273        chis12 = chis1 * chis2
27274        sig1 = sigmap1(itypi,itypj)
27275        sig2 = sigmap2(itypi,itypj)
27276 !c!       write (*,*) "sig1 = ", sig1
27277 !c!       write (*,*) "sig2 = ", sig2
27278 !c! alpha factors from Fcav/Gcav
27279        b1cav = alphasur(1,itypi,itypj)
27280 !       b1cav=0.0
27281        b2cav = alphasur(2,itypi,itypj)
27282        b3cav = alphasur(3,itypi,itypj)
27283        b4cav = alphasur(4,itypi,itypj)
27284        wqd = wquad(itypi, itypj)
27285 !c! used by Fgb
27286        eps_in = epsintab(itypi,itypj)
27287        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27288 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27289 !c!-------------------------------------------------------------------
27290 !c! tail location and distance calculations
27291        Rtail = 0.0d0
27292        DO k = 1, 3
27293       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27294       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27295        END DO
27296 !c! tail distances will be themselves usefull elswhere
27297 !c1 (in Gcav, for example)
27298        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27299        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27300        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27301        Rtail = dsqrt(  &
27302         (Rtail_distance(1)*Rtail_distance(1))  &
27303       + (Rtail_distance(2)*Rtail_distance(2))  &
27304       + (Rtail_distance(3)*Rtail_distance(3)))
27305 !c!-------------------------------------------------------------------
27306 !c! Calculate location and distance between polar heads
27307 !c! distance between heads
27308 !c! for each one of our three dimensional space...
27309        d1 = dhead(1, 1, itypi, itypj)
27310        d2 = dhead(2, 1, itypi, itypj)
27311
27312        DO k = 1,3
27313 !c! location of polar head is computed by taking hydrophobic centre
27314 !c! and moving by a d1 * dc_norm vector
27315 !c! see unres publications for very informative images
27316       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27317       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27318 !c! distance
27319 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27320 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27321       Rhead_distance(k) = chead(k,2) - chead(k,1)
27322        END DO
27323 !c! pitagoras (root of sum of squares)
27324        Rhead = dsqrt(   &
27325         (Rhead_distance(1)*Rhead_distance(1)) &
27326       + (Rhead_distance(2)*Rhead_distance(2)) &
27327       + (Rhead_distance(3)*Rhead_distance(3)))
27328 !c!-------------------------------------------------------------------
27329 !c! zero everything that should be zero'ed
27330        Egb = 0.0d0
27331        ECL = 0.0d0
27332        Elj = 0.0d0
27333        Equad = 0.0d0
27334        Epol = 0.0d0
27335        eheadtail = 0.0d0
27336        dGCLdOM1 = 0.0d0
27337        dGCLdOM2 = 0.0d0
27338        dGCLdOM12 = 0.0d0
27339        dPOLdOM1 = 0.0d0
27340        dPOLdOM2 = 0.0d0
27341        RETURN
27342       END SUBROUTINE elgrad_init
27343
27344
27345       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27346       use comm_momo
27347       use calc_data
27348        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27349        eps_out=80.0d0
27350        itypi = itype(i,1)
27351        itypj = itype(j,5)
27352 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27353 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27354 !c!       t_bath = 300
27355 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27356        Rb=0.001986d0
27357        BetaT = 1.0d0 / (298.0d0 * Rb)
27358 !c! Gay-berne var's
27359        sig0ij = sigmacat( itypi,itypj )
27360        chi1   = chi1cat( itypi, itypj )
27361        chi2   = 0.0d0
27362        chi12  = 0.0d0
27363        chip1  = chipp1cat( itypi, itypj )
27364        chip2  = 0.0d0
27365        chip12 = 0.0d0
27366 !c! not used by momo potential, but needed by sc_angular which is shared
27367 !c! by all energy_potential subroutines
27368        alf1   = 0.0d0
27369        alf2   = 0.0d0
27370        alf12  = 0.0d0
27371        dxj = dc_norm( 1, nres+j )
27372        dyj = dc_norm( 2, nres+j )
27373        dzj = dc_norm( 3, nres+j )
27374 !c! distance from center of chain(?) to polar/charged head
27375        d1 = dheadcat(1, 1, itypi, itypj)
27376        d2 = dheadcat(2, 1, itypi, itypj)
27377 !c! ai*aj from Fgb
27378        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27379 !c!       a12sq = a12sq * a12sq
27380 !c! charge of amino acid itypi is...
27381        Qi  = icharge(itypi)
27382        Qj  = ichargecat(itypj)
27383        Qij = Qi * Qj
27384 !c! chis1,2,12
27385        chis1 = chis1cat(itypi,itypj)
27386        chis2 = 0.0d0
27387        chis12 = 0.0d0
27388        sig1 = sigmap1cat(itypi,itypj)
27389        sig2 = sigmap2cat(itypi,itypj)
27390 !c! alpha factors from Fcav/Gcav
27391        b1cav = alphasurcat(1,itypi,itypj)
27392        b2cav = alphasurcat(2,itypi,itypj)
27393        b3cav = alphasurcat(3,itypi,itypj)
27394        b4cav = alphasurcat(4,itypi,itypj)
27395        wqd = wquadcat(itypi, itypj)
27396 !c! used by Fgb
27397        eps_in = epsintabcat(itypi,itypj)
27398        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27399 !c!-------------------------------------------------------------------
27400 !c! tail location and distance calculations
27401        Rtail = 0.0d0
27402        DO k = 1, 3
27403       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27404       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27405        END DO
27406 !c! tail distances will be themselves usefull elswhere
27407 !c1 (in Gcav, for example)
27408        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27409        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27410        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27411        Rtail = dsqrt(  &
27412         (Rtail_distance(1)*Rtail_distance(1))  &
27413       + (Rtail_distance(2)*Rtail_distance(2))  &
27414       + (Rtail_distance(3)*Rtail_distance(3)))
27415 !c!-------------------------------------------------------------------
27416 !c! Calculate location and distance between polar heads
27417 !c! distance between heads
27418 !c! for each one of our three dimensional space...
27419        d1 = dheadcat(1, 1, itypi, itypj)
27420        d2 = dheadcat(2, 1, itypi, itypj)
27421
27422        DO k = 1,3
27423 !c! location of polar head is computed by taking hydrophobic centre
27424 !c! and moving by a d1 * dc_norm vector
27425 !c! see unres publications for very informative images
27426       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27427       chead(k,2) = c(k, j)
27428 !c! distance
27429 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27430 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27431       Rhead_distance(k) = chead(k,2) - chead(k,1)
27432        END DO
27433 !c! pitagoras (root of sum of squares)
27434        Rhead = dsqrt(   &
27435         (Rhead_distance(1)*Rhead_distance(1)) &
27436       + (Rhead_distance(2)*Rhead_distance(2)) &
27437       + (Rhead_distance(3)*Rhead_distance(3)))
27438 !c!-------------------------------------------------------------------
27439 !c! zero everything that should be zero'ed
27440        Egb = 0.0d0
27441        ECL = 0.0d0
27442        Elj = 0.0d0
27443        Equad = 0.0d0
27444        Epol = 0.0d0
27445        eheadtail = 0.0d0
27446        dGCLdOM1 = 0.0d0
27447        dGCLdOM2 = 0.0d0
27448        dGCLdOM12 = 0.0d0
27449        dPOLdOM1 = 0.0d0
27450        dPOLdOM2 = 0.0d0
27451        RETURN
27452       END SUBROUTINE elgrad_init_cat
27453
27454       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27455       use comm_momo
27456       use calc_data
27457        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27458        eps_out=80.0d0
27459        itypi = 10
27460        itypj = itype(j,5)
27461 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27462 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27463 !c!       t_bath = 300
27464 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27465        Rb=0.001986d0
27466        BetaT = 1.0d0 / (298.0d0 * Rb)
27467 !c! Gay-berne var's
27468        sig0ij = sigmacat( itypi,itypj )
27469        chi1   = chi1cat( itypi, itypj )
27470        chi2   = 0.0d0
27471        chi12  = 0.0d0
27472        chip1  = chipp1cat( itypi, itypj )
27473        chip2  = 0.0d0
27474        chip12 = 0.0d0
27475 !c! not used by momo potential, but needed by sc_angular which is shared
27476 !c! by all energy_potential subroutines
27477        alf1   = 0.0d0
27478        alf2   = 0.0d0
27479        alf12  = 0.0d0
27480        dxj = 0.0d0 !dc_norm( 1, nres+j )
27481        dyj = 0.0d0 !dc_norm( 2, nres+j )
27482        dzj = 0.0d0 !dc_norm( 3, nres+j )
27483 !c! distance from center of chain(?) to polar/charged head
27484        d1 = dheadcat(1, 1, itypi, itypj)
27485        d2 = dheadcat(2, 1, itypi, itypj)
27486 !c! ai*aj from Fgb
27487        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27488 !c!       a12sq = a12sq * a12sq
27489 !c! charge of amino acid itypi is...
27490        Qi  = 0
27491        Qj  = ichargecat(itypj)
27492 !       Qij = Qi * Qj
27493 !c! chis1,2,12
27494        chis1 = chis1cat(itypi,itypj)
27495        chis2 = 0.0d0
27496        chis12 = 0.0d0
27497        sig1 = sigmap1cat(itypi,itypj)
27498        sig2 = sigmap2cat(itypi,itypj)
27499 !c! alpha factors from Fcav/Gcav
27500        b1cav = alphasurcat(1,itypi,itypj)
27501        b2cav = alphasurcat(2,itypi,itypj)
27502        b3cav = alphasurcat(3,itypi,itypj)
27503        b4cav = alphasurcat(4,itypi,itypj)
27504        wqd = wquadcat(itypi, itypj)
27505 !c! used by Fgb
27506        eps_in = epsintabcat(itypi,itypj)
27507        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27508 !c!-------------------------------------------------------------------
27509 !c! tail location and distance calculations
27510        Rtail = 0.0d0
27511        DO k = 1, 3
27512       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
27513       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27514        END DO
27515 !c! tail distances will be themselves usefull elswhere
27516 !c1 (in Gcav, for example)
27517        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27518        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27519        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27520        Rtail = dsqrt(  &
27521         (Rtail_distance(1)*Rtail_distance(1))  &
27522       + (Rtail_distance(2)*Rtail_distance(2))  &
27523       + (Rtail_distance(3)*Rtail_distance(3)))
27524 !c!-------------------------------------------------------------------
27525 !c! Calculate location and distance between polar heads
27526 !c! distance between heads
27527 !c! for each one of our three dimensional space...
27528        d1 = dheadcat(1, 1, itypi, itypj)
27529        d2 = dheadcat(2, 1, itypi, itypj)
27530
27531        DO k = 1,3
27532 !c! location of polar head is computed by taking hydrophobic centre
27533 !c! and moving by a d1 * dc_norm vector
27534 !c! see unres publications for very informative images
27535       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
27536       chead(k,2) = c(k, j)
27537 !c! distance
27538 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27539 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27540       Rhead_distance(k) = chead(k,2) - chead(k,1)
27541        END DO
27542 !c! pitagoras (root of sum of squares)
27543        Rhead = dsqrt(   &
27544         (Rhead_distance(1)*Rhead_distance(1)) &
27545       + (Rhead_distance(2)*Rhead_distance(2)) &
27546       + (Rhead_distance(3)*Rhead_distance(3)))
27547 !c!-------------------------------------------------------------------
27548 !c! zero everything that should be zero'ed
27549        Egb = 0.0d0
27550        ECL = 0.0d0
27551        Elj = 0.0d0
27552        Equad = 0.0d0
27553        Epol = 0.0d0
27554        eheadtail = 0.0d0
27555        dGCLdOM1 = 0.0d0
27556        dGCLdOM2 = 0.0d0
27557        dGCLdOM12 = 0.0d0
27558        dPOLdOM1 = 0.0d0
27559        dPOLdOM2 = 0.0d0
27560        RETURN
27561       END SUBROUTINE elgrad_init_cat_pep
27562
27563       double precision function tschebyshev(m,n,x,y)
27564       implicit none
27565       integer i,m,n
27566       double precision x(n),y,yy(0:maxvar),aux
27567 !c Tschebyshev polynomial. Note that the first term is omitted
27568 !c m=0: the constant term is included
27569 !c m=1: the constant term is not included
27570       yy(0)=1.0d0
27571       yy(1)=y
27572       do i=2,n
27573       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27574       enddo
27575       aux=0.0d0
27576       do i=m,n
27577       aux=aux+x(i)*yy(i)
27578       enddo
27579       tschebyshev=aux
27580       return
27581       end function tschebyshev
27582 !C--------------------------------------------------------------------------
27583       double precision function gradtschebyshev(m,n,x,y)
27584       implicit none
27585       integer i,m,n
27586       double precision x(n+1),y,yy(0:maxvar),aux
27587 !c Tschebyshev polynomial. Note that the first term is omitted
27588 !c m=0: the constant term is included
27589 !c m=1: the constant term is not included
27590       yy(0)=1.0d0
27591       yy(1)=2.0d0*y
27592       do i=2,n
27593       yy(i)=2*y*yy(i-1)-yy(i-2)
27594       enddo
27595       aux=0.0d0
27596       do i=m,n
27597       aux=aux+x(i+1)*yy(i)*(i+1)
27598 !C        print *, x(i+1),yy(i),i
27599       enddo
27600       gradtschebyshev=aux
27601       return
27602       end function gradtschebyshev
27603
27604       subroutine make_SCSC_inter_list
27605       include 'mpif.h'
27606       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27607       real*8 :: dist_init, dist_temp,r_buff_list
27608       integer:: contlisti(250*nres),contlistj(250*nres)
27609 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
27610       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
27611       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
27612 !            print *,"START make_SC"
27613         r_buff_list=5.0
27614           ilist_sc=0
27615           do i=iatsc_s,iatsc_e
27616            itypi=iabs(itype(i,1))
27617            if (itypi.eq.ntyp1) cycle
27618            xi=c(1,nres+i)
27619            yi=c(2,nres+i)
27620            zi=c(3,nres+i)
27621           call to_box(xi,yi,zi)
27622            do iint=1,nint_gr(i)
27623 !           print *,"is it wrong", iint,i
27624             do j=istart(i,iint),iend(i,iint)
27625              itypj=iabs(itype(j,1))
27626              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
27627              if (itypj.eq.ntyp1) cycle
27628              xj=c(1,nres+j)
27629              yj=c(2,nres+j)
27630              zj=c(3,nres+j)
27631              call to_box(xj,yj,zj)
27632 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27633 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27634           xj=boxshift(xj-xi,boxxsize)
27635           yj=boxshift(yj-yi,boxysize)
27636           zj=boxshift(zj-zi,boxzsize)
27637           dist_init=xj**2+yj**2+zj**2
27638 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27639 ! r_buff_list is a read value for a buffer
27640              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27641 ! Here the list is created
27642              ilist_sc=ilist_sc+1
27643 ! this can be substituted by cantor and anti-cantor
27644              contlisti(ilist_sc)=i
27645              contlistj(ilist_sc)=j
27646
27647              endif
27648            enddo
27649            enddo
27650            enddo
27651 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27652 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27653 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
27654 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
27655 #ifdef DEBUG
27656       write (iout,*) "before MPIREDUCE",ilist_sc
27657       do i=1,ilist_sc
27658       write (iout,*) i,contlisti(i),contlistj(i)
27659       enddo
27660 #endif
27661       if (nfgtasks.gt.1)then
27662
27663       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27664         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27665 !        write(iout,*) "before bcast",g_ilist_sc
27666       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
27667                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
27668       displ(0)=0
27669       do i=1,nfgtasks-1,1
27670         displ(i)=i_ilist_sc(i-1)+displ(i-1)
27671       enddo
27672 !        write(iout,*) "before gather",displ(0),displ(1)
27673       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
27674                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
27675                    king,FG_COMM,IERR)
27676       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
27677                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
27678                    king,FG_COMM,IERR)
27679       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
27680 !        write(iout,*) "before bcast",g_ilist_sc
27681 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27682       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27683       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27684
27685 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27686
27687       else
27688       g_ilist_sc=ilist_sc
27689
27690       do i=1,ilist_sc
27691       newcontlisti(i)=contlisti(i)
27692       newcontlistj(i)=contlistj(i)
27693       enddo
27694       endif
27695
27696 #ifdef DEBUG
27697       write (iout,*) "after MPIREDUCE",g_ilist_sc
27698       do i=1,g_ilist_sc
27699       write (iout,*) i,newcontlisti(i),newcontlistj(i)
27700       enddo
27701 #endif
27702       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
27703       return
27704       end subroutine make_SCSC_inter_list
27705 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
27706
27707       subroutine make_SCp_inter_list
27708       use MD_data,  only: itime_mat
27709
27710       include 'mpif.h'
27711       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27712       real*8 :: dist_init, dist_temp,r_buff_list
27713       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
27714 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
27715       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
27716       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
27717 !            print *,"START make_SC"
27718       r_buff_list=5.0
27719           ilist_scp=0
27720       do i=iatscp_s,iatscp_e
27721       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27722       xi=0.5D0*(c(1,i)+c(1,i+1))
27723       yi=0.5D0*(c(2,i)+c(2,i+1))
27724       zi=0.5D0*(c(3,i)+c(3,i+1))
27725         call to_box(xi,yi,zi)
27726       do iint=1,nscp_gr(i)
27727
27728       do j=iscpstart(i,iint),iscpend(i,iint)
27729         itypj=iabs(itype(j,1))
27730         if (itypj.eq.ntyp1) cycle
27731 ! Uncomment following three lines for SC-p interactions
27732 !         xj=c(1,nres+j)-xi
27733 !         yj=c(2,nres+j)-yi
27734 !         zj=c(3,nres+j)-zi
27735 ! Uncomment following three lines for Ca-p interactions
27736 !          xj=c(1,j)-xi
27737 !          yj=c(2,j)-yi
27738 !          zj=c(3,j)-zi
27739         xj=c(1,j)
27740         yj=c(2,j)
27741         zj=c(3,j)
27742         call to_box(xj,yj,zj)
27743       xj=boxshift(xj-xi,boxxsize)
27744       yj=boxshift(yj-yi,boxysize)
27745       zj=boxshift(zj-zi,boxzsize)
27746       dist_init=xj**2+yj**2+zj**2
27747 #ifdef DEBUG
27748             ! r_buff_list is a read value for a buffer
27749              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
27750 ! Here the list is created
27751              ilist_scp_first=ilist_scp_first+1
27752 ! this can be substituted by cantor and anti-cantor
27753              contlistscpi_f(ilist_scp_first)=i
27754              contlistscpj_f(ilist_scp_first)=j
27755             endif
27756 #endif
27757 ! r_buff_list is a read value for a buffer
27758              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27759 ! Here the list is created
27760              ilist_scp=ilist_scp+1
27761 ! this can be substituted by cantor and anti-cantor
27762              contlistscpi(ilist_scp)=i
27763              contlistscpj(ilist_scp)=j
27764             endif
27765            enddo
27766            enddo
27767            enddo
27768 #ifdef DEBUG
27769       write (iout,*) "before MPIREDUCE",ilist_scp
27770       do i=1,ilist_scp
27771       write (iout,*) i,contlistscpi(i),contlistscpj(i)
27772       enddo
27773 #endif
27774       if (nfgtasks.gt.1)then
27775
27776       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
27777         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27778 !        write(iout,*) "before bcast",g_ilist_sc
27779       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
27780                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
27781       displ(0)=0
27782       do i=1,nfgtasks-1,1
27783         displ(i)=i_ilist_scp(i-1)+displ(i-1)
27784       enddo
27785 !        write(iout,*) "before gather",displ(0),displ(1)
27786       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
27787                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
27788                    king,FG_COMM,IERR)
27789       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
27790                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
27791                    king,FG_COMM,IERR)
27792       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
27793 !        write(iout,*) "before bcast",g_ilist_sc
27794 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27795       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27796       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27797
27798 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27799
27800       else
27801       g_ilist_scp=ilist_scp
27802
27803       do i=1,ilist_scp
27804       newcontlistscpi(i)=contlistscpi(i)
27805       newcontlistscpj(i)=contlistscpj(i)
27806       enddo
27807       endif
27808
27809 #ifdef DEBUG
27810       write (iout,*) "after MPIREDUCE",g_ilist_scp
27811       do i=1,g_ilist_scp
27812       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
27813       enddo
27814
27815 !      if (ifirstrun.eq.0) ifirstrun=1
27816 !      do i=1,ilist_scp_first
27817 !       do j=1,g_ilist_scp
27818 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
27819 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
27820 !        enddo
27821 !       print *,itime_mat,"ERROR matrix needs updating"
27822 !       print *,contlistscpi_f(i),contlistscpj_f(i)
27823 !  126  continue
27824 !      enddo
27825 #endif
27826       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
27827
27828       return
27829       end subroutine make_SCp_inter_list
27830
27831 !-----------------------------------------------------------------------------
27832 !-----------------------------------------------------------------------------
27833
27834
27835       subroutine make_pp_inter_list
27836       include 'mpif.h'
27837       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27838       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
27839       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
27840       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
27841       integer:: contlistppi(250*nres),contlistppj(250*nres)
27842 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
27843       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
27844       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
27845 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
27846             ilist_pp=0
27847       r_buff_list=5.0
27848       do i=iatel_s,iatel_e
27849         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27850         dxi=dc(1,i)
27851         dyi=dc(2,i)
27852         dzi=dc(3,i)
27853         dx_normi=dc_norm(1,i)
27854         dy_normi=dc_norm(2,i)
27855         dz_normi=dc_norm(3,i)
27856         xmedi=c(1,i)+0.5d0*dxi
27857         ymedi=c(2,i)+0.5d0*dyi
27858         zmedi=c(3,i)+0.5d0*dzi
27859
27860         call to_box(xmedi,ymedi,zmedi)
27861         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
27862 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27863 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27864
27865 ! 1,j)
27866              do j=ielstart(i),ielend(i)
27867 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27868           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27869           dxj=dc(1,j)
27870           dyj=dc(2,j)
27871           dzj=dc(3,j)
27872           dx_normj=dc_norm(1,j)
27873           dy_normj=dc_norm(2,j)
27874           dz_normj=dc_norm(3,j)
27875 !          xj=c(1,j)+0.5D0*dxj-xmedi
27876 !          yj=c(2,j)+0.5D0*dyj-ymedi
27877 !          zj=c(3,j)+0.5D0*dzj-zmedi
27878           xj=c(1,j)+0.5D0*dxj
27879           yj=c(2,j)+0.5D0*dyj
27880           zj=c(3,j)+0.5D0*dzj
27881           call to_box(xj,yj,zj)
27882 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27883 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27884           xj=boxshift(xj-xmedi,boxxsize)
27885           yj=boxshift(yj-ymedi,boxysize)
27886           zj=boxshift(zj-zmedi,boxzsize)
27887           dist_init=xj**2+yj**2+zj**2
27888       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27889 ! Here the list is created
27890                  ilist_pp=ilist_pp+1
27891 ! this can be substituted by cantor and anti-cantor
27892                  contlistppi(ilist_pp)=i
27893                  contlistppj(ilist_pp)=j
27894               endif
27895 !             enddo
27896              enddo
27897              enddo
27898 #ifdef DEBUG
27899       write (iout,*) "before MPIREDUCE",ilist_pp
27900       do i=1,ilist_pp
27901       write (iout,*) i,contlistppi(i),contlistppj(i)
27902       enddo
27903 #endif
27904       if (nfgtasks.gt.1)then
27905
27906         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
27907           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27908 !        write(iout,*) "before bcast",g_ilist_sc
27909         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
27910                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
27911         displ(0)=0
27912         do i=1,nfgtasks-1,1
27913           displ(i)=i_ilist_pp(i-1)+displ(i-1)
27914         enddo
27915 !        write(iout,*) "before gather",displ(0),displ(1)
27916         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
27917                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
27918                          king,FG_COMM,IERR)
27919         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
27920                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
27921                          king,FG_COMM,IERR)
27922         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
27923 !        write(iout,*) "before bcast",g_ilist_sc
27924 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27925         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27926         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27927
27928 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27929
27930         else
27931         g_ilist_pp=ilist_pp
27932
27933         do i=1,ilist_pp
27934         newcontlistppi(i)=contlistppi(i)
27935         newcontlistppj(i)=contlistppj(i)
27936         enddo
27937         endif
27938         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
27939 #ifdef DEBUG
27940       write (iout,*) "after MPIREDUCE",g_ilist_pp
27941       do i=1,g_ilist_pp
27942       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
27943       enddo
27944 #endif
27945       return
27946       end subroutine make_pp_inter_list
27947
27948 !-----------------------------------------------------------------------------
27949       double precision function boxshift(x,boxsize)
27950       implicit none
27951       double precision x,boxsize
27952       double precision xtemp
27953       xtemp=dmod(x,boxsize)
27954       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
27955         boxshift=xtemp-boxsize
27956       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
27957         boxshift=xtemp+boxsize
27958       else
27959         boxshift=xtemp
27960       endif
27961       return
27962       end function boxshift
27963 !-----------------------------------------------------------------------------
27964       subroutine to_box(xi,yi,zi)
27965       implicit none
27966 !      include 'DIMENSIONS'
27967 !      include 'COMMON.CHAIN'
27968       double precision xi,yi,zi
27969       xi=dmod(xi,boxxsize)
27970       if (xi.lt.0.0d0) xi=xi+boxxsize
27971       yi=dmod(yi,boxysize)
27972       if (yi.lt.0.0d0) yi=yi+boxysize
27973       zi=dmod(zi,boxzsize)
27974       if (zi.lt.0.0d0) zi=zi+boxzsize
27975       return
27976       end subroutine to_box
27977 !--------------------------------------------------------------------------
27978       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
27979       implicit none
27980 !      include 'DIMENSIONS'
27981 !      include 'COMMON.IOUNITS'
27982 !      include 'COMMON.CHAIN'
27983       double precision xi,yi,zi,sslipi,ssgradlipi
27984       double precision fracinbuf
27985 !      double precision sscalelip,sscagradlip
27986 #ifdef DEBUG
27987       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
27988       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
27989       write (iout,*) "xi yi zi",xi,yi,zi
27990 #endif
27991       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
27992 ! the energy transfer exist
27993         if (zi.lt.buflipbot) then
27994 ! what fraction I am in
27995           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
27996 ! lipbufthick is thickenes of lipid buffore
27997           sslipi=sscalelip(fracinbuf)
27998           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
27999         elseif (zi.gt.bufliptop) then
28000           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
28001           sslipi=sscalelip(fracinbuf)
28002           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
28003         else
28004           sslipi=1.0d0
28005           ssgradlipi=0.0
28006         endif
28007       else
28008         sslipi=0.0d0
28009         ssgradlipi=0.0
28010       endif
28011 #ifdef DEBUG
28012       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
28013 #endif
28014       return
28015       end subroutine lipid_layer
28016
28017 !--------------------------------------------------------------------------
28018 !--------------------------------------------------------------------------
28019       end module energy